Copy rows based on two criteria to another worksheet

Question

We need to extract (on a daily basis) an Excel file out of a database with cases. This can run up to 400 or more cases by the end of the month. We need to check some cases that are not made by our department.

To make searching easier, I was thinking that VBA could filter the relevant files.

Our Excel file is built as follows:
Sheet 1 - "Overview"
Sheet 2 - "Input Filtered"
Sheet 3 - "Checked Cases"

In Sheet 2 the extracted data is pasted from row 2 and lower.
On Sheet 1 I have a button (ActiveX) created with the name "UpdateData". I would like to code that by clicking on this button, only the 'need to check' cases are copied to sheet 1 ("Overview").

The cases 'need to check' can be found by applying two criteria.

1. The case file number doesn't start with "52/"
2. The case file is not already on worksheet 3 "Checked Cases"

For criteria 1, the case file number, this is found on sheet 2 in column B. For criteria 2, the case file number on this sheet is found in column A.

Examples of case file numbers are '52/FHS/5110583/169/23' and '30/CD3/5119550/172/23'.

So far this is all I have:

Private Sub UpdateData_Click()

    Dim wsSource As Worksheet, wsTarget As Worksheet, WsHSource As Worksheet

    With ThisWorkbook
        Set wsTarget = .Sheets("Overview")
        Set wsSource = .Sheets("Input")
        Set WsHSource = .Sheets("Input Filtered")
     End With

    wsTarget.Range("B7:I500").ClearContents
    WsHSource.Range("A2:H494").ClearContents
    wsSource.Range("A2:C494").Copy
    WsHSource.Range("A2:C494").PasteSpecial xlPasteValues
    wsSource.Range("E2:I494").Copy
    WsHSource.Range("D2:H494").PasteSpecial xlPasteValues

End Sub

I made a first copy to only select the relevant columns. So, when I copy a row from "Input Filtered" to "Overview", we only see the 'need to check' info to find a file in our system.

Answer 1

Copy Rows in A Tricky VBA Lookup

Private Sub UpdateData_Click()
    
    Const LKP_NAME As String = "Checked Cases"
    Const LKP_FIRST_CELL As String = "A2"
    
    Const SRC_NAME As String = "Input"
    Const SRC_FIRST_ROW As String = "A2:I2"
    Const SRC_LOOKUP_COLUMN As Long = 2
    Dim sColumns(): sColumns = VBA.Array(1, 2, 3, 5, 6, 7, 8, 9)
    Const SRC_DOES_NOT_BEGIN_WITH As String = "52/"
    
    Const DST_NAME As String = "Overview"
    Const DST_FIRST_CELL As String = "B7"
    
    Dim wb As Workbook: Set wb = ThisWorkbook  ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    
    Dim srg As Range, srCount As Long, scCount As Long, sMaxCol As Long
    
    With sws.Range(SRC_FIRST_ROW)
        scCount = .Columns.Count
        sMaxCol = Application.Max(sColumns)
        If scCount < sMaxCol Then
            MsgBox "There needs to be at least " & sMaxCol & " columns " _
                & "in the source first row """ & SRC_FIRST_ROW & """.", _
                vbCritical
            Exit Sub
        End If
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then
            MsgBox "No data in the source worksheet """ & SRC_NAME & """ .", _
                vbCritical
            Exit Sub
        End If
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    Dim sData(): sData = srg.Value ' multiple cells are ensured
    
    Dim snUpper As Long: snUpper = UBound(sColumns)
    Dim sLen As Long: sLen = Len(SRC_DOES_NOT_BEGIN_WITH)
    
    ' Lookup
    
    Dim lws As Worksheet: Set lws = wb.Sheets(LKP_NAME)
    
    Dim lrg As Range, lrCount As Long
    
    With lws.Range(LKP_FIRST_CELL)
        Dim llCell As Range: Set llCell = .Resize(lws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not llCell Is Nothing Then
            lrCount = llCell.Row - .Row + 1
            Set lrg = .Resize(lrCount)
        End If
    End With
    
    Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
    lDict.CompareMode = vbTextCompare
    
    If lrCount > 0 Then
        Dim lData(), lr As Long, lStr As String
        If lrCount = 1 Then ' single cell
            ReDim lData(1 To 1, 1 To 1): lData(1, 1) = lrg.Value
        Else ' multiple cells
            lData = lrg.Value
        End If
        For lr = 1 To lrCount
            lStr = CStr(lData(lr, 1))
            If Len(lStr) > 0 Then
                lDict(lStr) = Empty
            End If
        Next lr
    End If
    
    ' Destination
    
    Dim dcCount As Long: dcCount = snUpper + 1
    Dim dData(): ReDim dData(1 To srCount, 1 To dcCount)
    
    ' The Loop
    
    Dim sr As Long, sc As Long, sn As Long, dr As Long, dc As Long, sPos As Long
    Dim sStr As String
    
    For sr = 1 To srCount
        sStr = sData(sr, SRC_LOOKUP_COLUMN)
        If Not lDict.Exists(sStr) Then ' is not checked
            sPos = InStr(1, sStr, SRC_DOES_NOT_BEGIN_WITH, vbTextCompare)
            If sPos <> 1 Then ' doesn't begin with
                dr = dr + 1
                dc = 0
                For sn = 0 To snUpper
                    sc = sColumns(sn)
                    dc = dc + 1
                    dData(dr, dc) = sData(sr, sc)
                Next sn
            End If
        End If
    Next sr
    
    ' Destination
        
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    
    Dim drg As Range
    
    With dws.Range(DST_FIRST_CELL)
        .Resize(dws.Rows.Count - .Row + 1, dcCount).ClearContents
        If dr = 0 Then
            MsgBox "No cases found.", vbExclamation
        Else
            Set drg = .Resize(dr, dcCount)
            drg.Value = dData
            MsgBox dr & " row" & IIf(dr = 1, "", "s") _
                & " of cases copied to the destination worksheet (""" _
                & DST_NAME & """).", vbInformation
        End If
    End With

End Sub