根据两个条件将行复制到另一个工作表

Question

我们需要（每天）从包含案例的数据库中提取 Excel 文件。到月底可能会处理多达 400 个或更多案例。我们需要检查一些不是我们部门制作的案例。

为了方便搜索，我想到VBA可以过滤相关文件。

我们的Excel文件构建如下：
第 1 页 - “概述”
表 2 -“输入已过滤”
表 3 - “已检查案例”

在工作表 2 中，从第 2 行及以下行粘贴提取的数据。
在工作表 1 上，我创建了一个名为“UpdateData”的按钮 (ActiveX)。我想编写代码，通过单击此按钮，仅将“需要检查”的案例复制到工作表 1（“概述”）。

可以通过应用两个标准来找到“需要检查”的案例。

1. 案件卷号不以“52/”开头
2. 案例档案尚未出现在工作表 3“已检查案例”中

对于标准 1，即案件卷宗编号，可在第 2 页的 B 列中找到。 对于标准 2，此表上的案件卷宗编号可在 A 列中找到。

案件档案编号示例为“52/FHS/5110583/169/23”和“30/CD3/5119550/172/23”。

到目前为止，这就是我所拥有的：

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

我制作了第一个副本以仅选择相关列。因此，当我将一行从“输入过滤”复制到“概述”时，我们只看到“需要检查”信息以在我们的系统中查找文件。

Answer 1

在棘手的 VBA 查找中复制行

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

Answer 2

检查值是否不以“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