excel - 比较列与范围并在 VBA 中的多个工作表之间删除

Question

我正在尝试比较两个产品列表。如果从 Sheet2 进行匹配，我想删除 Sheet1 中的整行。

Sheet1(有 17226 行)

ITEMID     WAREHOUSEID     QUANTITY     UNIT     PRICE     LOCATIONID
1000       1               100          EA       1.00      30
1001       1               100          EA       1.00      30
1002       1               100          EA       1.00      30
1003       1               100          EA       1.00      30
1004       1               100          EA       1.00      30
1005       1               100          EA       1.00      30
1006       1               100          EA       1.00      30
1007       1               100          EA       1.00      30
1008       1               100          EA       1.00      30

Sheet2(有 977 行)

1002
1004
1006
1008

我相信如果我遍历 Sheet2 的 A 列中的值并将它们与 Sheet1 中的每个 ITEMID 进行比较(这是 Sheet1 中的 E 列)，我相信它会起作用。

我写了这段代码，但它似乎什么也没做:

Sub Delete()
    Dim LastRow As Long
    Dim i As Long
    Dim rngCell As Range
    LastRow = Range("Sheet1!E17226").End(xlUp).Row
    
    For Each rngCell In Range("Sheet2!A1:A977")
        For i = LastRow To 1 Step -1
            If Range("E" & i).Value = rngCell.Value Then
                Range("E" & i).EntireRow.Delete
            End If
        Next
    Next
End Sub

请指出我的错误，以便我可以修复并运行 VBA 脚本，谢谢。

Answer 1

删除行

基本(两个循环)

Sub BasicTwoLoops() ' slow (takes forever)
    
    Const sfRow As Long = 2
    Const sCol As String = "A"
    
    Const dfRow As Long = 2
    Const dCol As String = "E"
    
    Dim sws As Worksheet: Set sws = Sheet2
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    
    Dim dws As Worksheet: Set dws = Sheet1
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "E").End(xlUp).Row
    
    Dim sValue As Variant
    Dim sr As Long
    Dim dValue As Variant
    Dim dr As Long
    
    For dr = dlRow To dfRow Step -1
        dValue = dws.Cells(dr, dCol).Value
        For sr = sfRow To slRow
            sValue = sws.Cells(sr, sCol).Value
            If dValue = sValue Then
                dws.Cells(dr, dCol).EntireRow.Delete
                Exit For
            End If
        Next sr
    Next dr

End Sub

Application.Match 壮举。 Range.Union

Sub UseRangesWithUnion() ' fast
 ' Uses 'RefCombinedRange'
    
    Const sfRow As Long = 2
    Const sCol As String = "A"
    
    Const dfRow As Long = 2
    Const dCol As String = "E"
    
    Dim sws As Worksheet: Set sws = Sheet2
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    
    Dim dws As Worksheet: Set dws = Sheet1
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "E").End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    Dim drg As Range: Set drg = dws.Cells(dfRow, dCol).Resize(drCount)
    
    Dim sCell As Range
    Dim sIndex As Variant
    Dim ddrg As Range
    Dim dCell As Range
    Dim dValue As Variant
    
    For Each dCell In drg.Cells
        dValue = dCell.Value
        sIndex = Application.Match(dValue, srg, 0)
        If IsNumeric(sIndex) Then
            Set ddrg = RefCombinedRange(ddrg, dCell)
        End If
    Next dCell
    
    If ddrg Is Nothing Then Exit Sub
    
    ddrg.EntireRow.Delete

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function

Range.AutoFilter

Sub UseAutoFilter() ' fastest
' Uses 'GetColumnRange'
' Uses 'ArrStringDataColumn'
' Source headers are not included in the range.
' Destination headers are included in the range.
    
    Const sfRow As Long = 2
    Const sCol As String = "A"
    
    Const dfRow As Long = 1 ' Headers included
    Const dCol As String = "E"
    
    Dim sws As Worksheet: Set sws = Sheet2
    Dim dws As Worksheet: Set dws = Sheet1

    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    Dim sData As Variant: sData = GetColumnRange(srg) ' 2D one-based
    Dim sArr As Variant: sArr = ArrStringDataColumn(sData, 1) ' 1D zero-based
    If IsEmpty(sArr) Then Exit Sub
    
    If dws.AutoFilterMode Then
        dws.AutoFilterMode = False
    End If
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    Dim drg As Range: Set drg = dws.Cells(dfRow, dCol).Resize(drCount)
    Dim ddrg As Range: Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
    
    drg.AutoFilter 1, sArr, xlFilterValues
    
    On Error Resume Next
    ddrg.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    On Error GoTo 0
    
    dws.AutoFilterMode = False

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a column of a 2D array, converted to 
'               a string, in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrStringDataColumn( _
    ByVal sData As Variant, _
    ByVal sColumnIndex As Long, _
    Optional ByVal dFirstIndex As Long) _
As Variant
    Const ProcName As String = "ArrDataColumn"
    On Error GoTo ClearError
    
    Dim sLower As Long: sLower = LBound(sData, 1)
    Dim sUpper As Long: sUpper = UBound(sData, 1)
    
    Dim IndexDiff As Long: IndexDiff = sLower - dFirstIndex
    Dim dArr As Variant: ReDim dArr(dFirstIndex To sUpper - IndexDiff)
    
    Dim r As Long
    
    For r = sLower To sUpper
        dArr(r - IndexDiff) = CStr(sData(r, sColumnIndex))
    Next r
    
    ArrStringDataColumn = dArr

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a column ('ColumnNumber')
'               of a range ('rg') to a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnNumber As Long = 1) _
As Variant
    If rg Is Nothing Then Exit Function
    If ColumnNumber < 1 Then Exit Function
    If ColumnNumber > rg.Columns.Count Then Exit Function
    
    With rg.Columns(ColumnNumber)
        If rg.Rows.Count = 1 Then
            Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
            GetColumnRange = Data
        Else
            GetColumnRange = .Value
        End If
    End With

End Function