在一个棘手的任务中复制任务

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

检查值是否不以“52/”开头且不在第3页A列中的示例

Sub CheckValuesInSheet2()
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim cell As Range
    Dim lastRow As Long
    
    ' Set the worksheets
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    
    ' Get the last row in Sheet2, Column B
    lastRow = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    
    ' Loop through each cell in Sheet2, Column B
    For Each cell In ws2.Range("B2:B" & lastRow)
        ' Check if the value doesn't start with "52/" and is not in Sheet3, Column A
        If Not Left(cell.value, 3) = "52/" And _
            Application.CountIf(ws3.Columns("A"), cell.value) = 0 Then
            'make the cell color red
            cell.Font.Color = RGB(255, 0, 0)
        End If
    Next cell
End Sub