Compare column to range and delete between multiple sheets in VBA-CodePudding

I'm trying to compare two lists of products. I want to delete the entire row in Sheet1 if a match is made from Sheet2.

Sheet1 (has 17226 rows)

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 (has 977 rows)

I believe it'd work if I iterate through the values in Column A of Sheet2 and compare them against each ITEMID in Sheet1 (this is Column E in Sheet1).

I wrote this code, but it doesn't seem to do anything:

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

Please point out my mistake so I can fix and run the VBA script, thank you.

CodePudding user response：

Delete Rows

Basic (Two Loops)

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 feat. 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 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 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
    
    Dim dws As Worksheet: Set dws = Sheet1
    dws.AutoFilterMode = False
    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 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

CodePudding user response：

Maybe something like this?

Note how explicit the Range references are. For example, where you have If Range("E" & i).Value in your code, that Range object implicitly attaches to the ActiveSheet, which could be Shee1 or Sheet2.

Public Sub Delete()

    Dim rng1 As Range, rng2 As Range, r1 As Range, r2 As Range
    Set rng1 = ThisWorkbook.Worksheets("Sheet1").Range("A1:A17226")
    Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:A997")
    
    For Each r2 In rng2
        Set r1 = rng1.Find(What:=r2.Value, LookAt:=xlWhole)
        If Not r1 Is Nothing Then
            r1.EntireRow.Delete
        End If
    Next
    
End Sub