我正在尝试修复以下脚本。 它的目的是根据数组搜索将整行从一张纸复制到另一张纸。 目前它不起作用，并在第 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
对此的任何帮助都将是非凡的，提前感谢您的帮助
答案 0 :(得分：2)
尝试使用 autofilter
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
答案 1 :(得分：1)
Criteria 数组中 K 列中的任何值的所有行复制到另一个工作表。For Each Next 循环，使用 Application.Match 来避免另一个循环，并使用 Union 将匹配的单元格组合成一个范围，最终将一次复制整个行。
代码
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