Excel VBA - Copy Entire Row to Another Sheet based on Array Match

Question

I have the following script that I am trying to fix. Its aim is to copy an entire row from one sheet to another based on an Array search. Currently it doesnt work, and throws an error on line 13 "Type Mismatch" on

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

I am no sure how to correct this error. This has been adapted from a functional script that looked for a String only (whatyousearchingfor) and I am trying to convert this to be able to handle an Array as an input instead

'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

Any help on this would be phenomenal, thank you for the assistance in advance

Remove the `on error resume next` and see if there is an error. Sometimes (almost always) you actually want to give an f about errors. — Warcupine, Feb 09 '21 at 19:13
very fair indeed. Error Type Mismatch on Line 13 "If CStr(Range(k).Value) = whatyousearchingfor Then" — Batteredburrito, Feb 09 '21 at 19:16
https://stackoverflow.com/questions/11109832/how-to-find-if-an-array-contains-a-string — Warcupine, Feb 09 '21 at 19:20
Please don't do `Dim Range As Range`. Use some more meaningful variable name and don't shadow built-in members of the object library. — BigBen, Feb 09 '21 at 19:27
Thanks BigBen, I will change this on my corrections. Thank you for the link Warcupine I will see what I can do with this — Batteredburrito, Feb 09 '21 at 19:44

score 1 · Accepted Answer · answered Feb 09 '21 at 19:44

Try this as perhaps a simpler solution using 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

Hi JohnnieL, This creates the column headers within the "Cleaned Data" sheet but doesnt seem to return any rows unfortunately. Does the data in Full System List need to be a table? Thank you for taking the time to help btw, its really appreciated — Batteredburrito, Feb 09 '21 at 19:49
" Does the data in Full System List need to be a table?" no - it may be that its filtering on the wrong column: It will only return headers and no data if no data after filter: comment out the last line `wsIn.UsedRange.AutoFilter` and it will leave the filter in place so you can see what is not working: likely it is filtering on the wrong column - can u screenshot with column headings the first few rows of the "DONT DELETE" sheet — JohnnieL, Feb 09 '21 at 19:52
Ignore me, this functions perfectly, had an issue with data having a space at the start. Have removed and this works perfectly — Batteredburrito, Feb 09 '21 at 19:52

VBasic2008 · Answer 2 · 2021-02-09T19:53:19.090

Transfer Array Matches

The following will copy all rows, containing any of the values in the Criteria array, in column K, to another worksheet.
It uses a For Each Next loop, Application.Match to avoid another loop, and Union to combine matching cells into a range, whose entire rows will finally be copied in one go.

The Code

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

Many thanks VBasic, this functions perfectly after removing the rogue space at the start of my data — Batteredburrito, Feb 09 '21 at 19:53

Excel VBA - Copy Entire Row to Another Sheet based on Array Match

2 Answers2

Transfer Array Matches