Excel VBA-基于数组匹配将整行复制到另一张图纸

我正在尝试修复以下脚本。 其目的是基于数组搜索将整行从一张图纸复制到另一张图纸。 目前它不工作，在第13行抛出一个错误

If CStr(Range(k).Value) = whatyousearchingfor Then 

我不知道如何纠正这个错误。这是从一个只查找字符串whatyousearchingfor的函数脚本改编而来的，我试图将其转换为能够将数组作为输入处理

'All this crappy script does is search for shit in column K, if it matches, copy entire damn row to another workbook
Sub CellShift()

'variables.
Dim Range As Range
Dim Cell As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim whatyousearchingfor

whatyousearchingfor = Array( _
"HP EliteBook 840 G3", _
"HP EliteBook 840 G6", _
"HP EliteBook 840 G5", _
"HP EliteDesk 800 G3 SFF", _
"HP EliteDesk 800 G2 SFF", _
"HP EliteBook 850 G3", _
"HP EliteDesk 800 G2 TWR", _
"HP EliteDesk 800 G4 SFF", _
"HP ProOne 600 G4 21.5-in Touch AiO", _
"HP ZBook 15u G6", _
"HP EliteBook 850 G5", _
"HP ZBook 15u G3", _
"HP EliteDesk 800 G2 DM 35W", _
"HP EliteDesk 800 G3 DM 35W", _
"HP EliteBook 850 G6", _
"HP EliteDesk 800 G4 DM 65W" _
)


'Change " " to anything your sheet is called
i = Worksheets("DONT DELETE - Full System List").UsedRange.Rows.count
j = Worksheets("Cleaned Tables").UsedRange.Rows.count
    
    'Make sure the space is free. If not, find a free space.
    If j = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("Cleaned Tables").UsedRange) = 0 Then j = 0
    End If

    'Set active range as Column, wont work otherwise.
    Set Range = Worksheets("DONT DELETE - Full System List").Range("K2:K" & i)

    'Set to false to save some compute power if your pc is shit.
    Application.ScreenUpdating = True

    'Magic goes below here not above.
        For k = 1 To Range.count
            'Looking for your stuff
            If CStr(Range(k).Value) = whatyousearchingfor Then
                'Do the shit plz
                Range(k).EntireRow.Copy Destination:=Worksheets("Cleaned Tables").Range("A" & j + 1)
        
                'Can add a delete here if you really want. Wouldnt recommend it...kinda destructive...just remove the ' on next line
                'Range(k).EntireRow.Delete
    
                
                'Gotta move onto the next row
                    If CStr(Range(k).Value) = whatyousearchingfor Then
                        'now shift that row on the other sheet, otherwise youll loop forever and get nowhere.
                        j = j + 1
                        'if you enabled row delete above, turn this on too:
                        'k = k -1
                    'Close that if
                    End If
            'Close that if x2
            End If
        'NEXT!
        Next
    'Okay, can stop, undo that screen pause
    Application.ScreenUpdating = True
'TADA (Hopefully)
End Sub

---

在这方面的任何帮助都将是巨大的，提前感谢您的帮助

尝试使用autofilter作为更简单的解决方案

---

尝试使用autofilter作为更简单的解决方案

传输数组匹配 下面将把K列中包含条件数组中任何值的所有行复制到另一个工作表中。 它为下一个循环使用一个For，Application.Match以避免另一个循环，Union将匹配的单元格组合到一个区域中，该区域的所有行最终将一次性复制。 代码

传输数组匹配 下面将把K列中包含条件数组中任何值的所有行复制到另一个工作表中。 它为下一个循环使用一个For，Application.Match以避免另一个循环，Union将匹配的单元格组合到一个区域中，该区域的所有行最终将一次性复制。 代码

---

下一步删除错误恢复，查看是否有错误。有时候，你几乎总是想给错误打个f，这是非常公平的。第13行的错误类型不匹配，如果CSTRANGEK.Value=whatyousearchingfor，请不要将Dim Range作为Range执行。使用一些更有意义的变量名，不要对对象库的内置成员进行阴影处理。谢谢BigBen，我会在更正后更改它。谢谢你的链接，我会看看我能做些什么删除错误恢复下一步，看看是否有错误。有时候，你几乎总是想给错误打个f，这是非常公平的。第13行的错误类型不匹配，如果CSTRANGEK.Value=whatyousearchingfor，请不要将Dim Range作为Range执行。使用一些更有意义的变量名，不要对对象库的内置成员进行阴影处理。谢谢BigBen，我会在更正后更改它。感谢您提供的链接Warcupine，我将看看我能用thisHi JohnnieL做些什么，这会在已清理的数据表中创建列标题，但不幸的是，似乎不会返回任何行。完整系统列表中的数据是否需要是表？谢谢你花时间来帮助顺便说一句，它真的很感激在完整的系统列表中的数据需要是一个表吗？否-这可能是因为它在错误的列上进行了筛选：如果筛选后没有数据，它将只返回标题，而不返回数据：注释掉最后一行wsIn.UsedRange.AutoFilter，它将保留筛选器，以便您可以看到不起作用的内容：很可能它在错误的列上进行了筛选-能否使用前几行的列标题进行屏幕截图对于DONT DELETE Sheet Ignore me，此功能非常完善，数据在开始时有空格。已经删除了，这很好用——thanksHi JohnnieL，这在清理过的数据表中创建了列标题，但不幸的是似乎没有返回任何行。完整系统列表中的数据是否需要是表？谢谢你花时间来帮助顺便说一句，它真的很感激在完整的系统列表中的数据需要是一个表吗？否-这可能是因为它在错误的列上进行了筛选：如果筛选后没有数据，它将只返回标题，而不返回数据：注释掉最后一行wsIn.UsedRange.AutoFilter，它将保留筛选器，以便您可以看到不起作用的内容：很可能它在错误的列上进行了筛选-能否使用前几行的列标题进行屏幕截图对于DONT DELETE Sheet Ignore me，此功能非常完善，数据在开始时有空格。已经删除，这工作得很好啊，太好了-谢谢很多感谢VBasic，在我的数据开始时删除流氓空间后，这个功能非常好很多感谢VBasic，在我的数据开始时删除流氓空间后，这个功能非常好

option explicit
Sub CellShift_2()
  Dim whatyousearchingfor() As Variant
  
  whatyousearchingfor = Array( _
  "HP EliteBook 840 G3", _
  "HP EliteBook 840 G6", _
  "HP EliteBook 840 G5", _
  "HP EliteDesk 800 G3 SFF", _
  "HP EliteDesk 800 G2 SFF", _
  "HP EliteBook 850 G3", _
  "HP EliteDesk 800 G2 TWR", _
  "HP EliteDesk 800 G4 SFF", _
  "HP ProOne 600 G4 21.5-in Touch AiO", _
  "HP ZBook 15u G6", _
  "HP EliteBook 850 G5", _
  "HP ZBook 15u G3", _
  "HP EliteDesk 800 G2 DM 35W", _
  "HP EliteDesk 800 G3 DM 35W", _
  "HP EliteBook 850 G6", _
  "HP EliteDesk 800 G4 DM 65W" _
  )
  Dim wsIn As Worksheet
  Set wsIn = Worksheets("DONT DELETE - Full System List")
  
'field 11 corresponds to column K
  wsIn.UsedRange.AutoFilter field:=11, Criteria1:=whatyousearchingfor, _
    Operator:=xlFilterValues
  
  Dim wsOut As Worksheet
  Set wsOut = Worksheets("Cleaned Tables")
  
  Dim rOut As Range
  Dim header_offset As Long
  If IsEmpty(wsOut.Range("a1").Value) Then
    Set rOut = wsOut.Range("a1")
    header_offset = 0
  Else
    Set rOut = wsOut.Range("a1").Offset(wsOut.UsedRange.Rows.Count, 0)
    header_offset = 1
  End If
  
  'assume we have at least 1 row of data below headers
  ' add "on error" to accomodate zero rows after filter applied
  On Error Resume Next
  wsIn.Range(wsIn.Range("a1").Offset(header_offset, 0), _
      wsIn.Cells(wsIn.UsedRange.Rows.Count, wsIn.UsedRange.Columns.Count)) _
      .SpecialCells(xlCellTypeVisible).Copy rOut
  On Error GoTo 0
  
  'turn off autofilter
  wsIn.UsedRange.AutoFilter
  

End Sub

Option Explicit

Sub transferArrayMatches()
    
    ' Define constants.
    Const srcName As String = "DONT DELETE - Full System List"
    Const srcFirst As String = "K2"
    Const dstName As String = "Cleaned Tables"
    Const dstFirst As String = "A2"
    Dim Criteria As Variant
    Criteria = Array( _
        "HP EliteBook 840 G3", _
        "HP EliteBook 840 G6", _
        "HP EliteBook 840 G5", _
        "HP EliteDesk 800 G3 SFF", _
        "HP EliteDesk 800 G2 SFF", _
        "HP EliteBook 850 G3", _
        "HP EliteDesk 800 G2 TWR", _
        "HP EliteDesk 800 G4 SFF", _
        "HP ProOne 600 G4 21.5-in Touch AiO", _
        "HP ZBook 15u G6", _
        "HP EliteBook 850 G5", _
        "HP ZBook 15u G3", _
        "HP EliteDesk 800 G2 DM 35W", _
        "HP EliteDesk 800 G3 DM 35W", _
        "HP EliteBook 850 G6", _
        "HP EliteDesk 800 G4 DM 65W")
    
    ' Define workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    ' Define Source Range.
    Dim srg As Range
    With wb.Worksheets(srcName).Range(srcFirst)
        Set srg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If srg Is Nothing Then Exit Sub
        Set srg = .Resize(srg.Row - .Row + 1)
    End With
    
    ' Define Destination Cell Range.
    Dim dCell As Range
    With wb.Worksheets(dstName).Range(dstFirst)
        Set dCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If dCell Is Nothing Then
            Set dCell = .Offset
        Else
            Set dCell = dCell.Offset(1)
        End If
    End With
    
    Dim crg As Range
    Dim sCell As Range
    Dim cValue As Variant
    Dim cMatch As Variant
    
    ' Combine all matching cells into Copy Range.
    For Each sCell In srg.Cells
        If Not IsError(sCell) Then
            If Len(sCell.Value) > 0 Then
                cValue = sCell.Value
                cMatch = Application.Match(cValue, Criteria, 0)
                If IsNumeric(cMatch) Then
                    If crg Is Nothing Then
                        Set crg = sCell
                    Else
                        Set crg = Union(crg, sCell)
                    End If
                End If
            End If
        End If
    Next sCell
    
    ' Copy entire rows (rows of worksheet) of Copy Range to Destination Range.
    Application.ScreenUpdating = False
    If Not crg Is Nothing Then
        crg.EntireRow.Copy dCell
        'crg.EntireRow.Delete ' if you wanna delete
    End If
    Application.ScreenUpdating = True
    
    MsgBox "Data transferred (TADA).", vbInformation, "Success"

End Sub