如何用VBA批量删除Vendor列值匹配Lookup列的Excel行

Hey there, let's get that slow VBA code sorted out! The problem with your current approach is that checking one value at a time drags things down—especially if you've got a large dataset. Below are two optimized, batch-focused solutions that'll handle this way faster:

This method leverages Excel's AutoFilter to select all matching rows in one go, then deletes them. Worksheet operations are the slowest part of VBA, so minimizing those is key.

Sub BatchDeleteMatchingVendors()
    Dim wsMain As Worksheet, wsLookup As Worksheet
    Dim lookupVals As Variant, filterArray As Variant
    Dim lastRowMain As Long, lastRowLookup As Long
    Dim mainVendorCol As Long, lookupVendorCol As Long
    Dim i As Long
    
    ' Set your worksheet references (adjust lookup sheet name if needed)
    Set wsMain = ThisWorkbook.Worksheets("MainSheet")
    Set wsLookup = ThisWorkbook.Worksheets("LookupSheet")
    
    ' Dynamically find column positions (so code works if columns move)
    On Error Resume Next
    mainVendorCol = wsMain.Rows(1).Find(What:="Vendor", LookIn:=xlValues, LookAt:=xlWhole).Column
    lookupVendorCol = wsLookup.Rows(1).Find(What:="lookupVendor", LookIn:=xlValues, LookAt:=xlWhole).Column
    On Error GoTo 0
    
    ' Exit if columns aren't found
    If mainVendorCol = 0 Or lookupVendorCol = 0 Then
        MsgBox "Couldn't find Vendor or lookupVendor column headers!", vbExclamation
        Exit Sub
    End If
    
    ' Pull all lookup values into an array (way faster than cell-by-cell access)
    lastRowLookup = wsLookup.Cells(wsLookup.Rows.Count, lookupVendorCol).End(xlUp).Row
    lookupVals = wsLookup.Range(wsLookup.Cells(2, lookupVendorCol), wsLookup.Cells(lastRowLookup, lookupVendorCol)).Value
    
    ' Convert 2D array to 1D (AutoFilter expects a 1D array for multiple values)
    ReDim filterArray(1 To UBound(lookupVals, 1))
    For i = 1 To UBound(lookupVals, 1)
        filterArray(i) = lookupVals(i, 1)
    Next i
    
    ' Speed up execution by disabling screen updates/events
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    With wsMain
        lastRowMain = .Cells(.Rows.Count, mainVendorCol).End(xlUp).Row
        
        ' Clear existing filters if any
        If .FilterMode Then .ShowAllData
        
        ' Apply filter to match lookup vendors
        .Range(.Cells(1, mainVendorCol), .Cells(lastRowMain, mainVendorCol)).AutoFilter _
            Field:=1, Criteria1:=filterArray, Operator:=xlFilterValues
        
        ' Delete visible rows (skip header row)
        On Error Resume Next ' Avoid error if no matching rows exist
        .Range(.Cells(2, mainVendorCol), .Cells(lastRowMain, mainVendorCol)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        
        ' Remove filter
        .ShowAllData
    End With
    
    ' Restore settings
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Matching vendor rows deleted successfully!", vbInformation
End Sub

Why this works: #

• Array lookup: We grab all lookup values at once instead of looping through cells, cutting down on slow worksheet interactions.
• AutoFilter batch operation: Filters all matching rows in a single step, then deletes them all at once—no row-by-row checks.
• Dynamic column detection: Uses Find to locate headers, so your code won't break if columns are rearranged.
• Error handling: Includes checks for missing columns and no matching rows to prevent crashes.

If you need finer control over individual rows (e.g., logging deleted rows), this uses a Scripting Dictionary for O(1) lookups, which is still way faster than your original single-value check. We loop backwards to avoid skipping rows when deleting.

Sub DeleteVendorsWithDictionary()
    Dim wsMain As Worksheet, wsLookup As Worksheet
    Dim lookupDict As Object
    Dim lastRowMain As Long, lastRowLookup As Long
    Dim mainVendorCol As Long, lookupVendorCol As Long
    Dim i As Long
    
    Set wsMain = ThisWorkbook.Worksheets("MainSheet")
    Set wsLookup = ThisWorkbook.Worksheets("LookupSheet")
    Set lookupDict = CreateObject("Scripting.Dictionary")
    
    ' Find column positions dynamically
    On Error Resume Next
    mainVendorCol = wsMain.Rows(1).Find(What:="Vendor", LookIn:=xlValues, LookAt:=xlWhole).Column
    lookupVendorCol = wsLookup.Rows(1).Find(What:="lookupVendor", LookIn:=xlValues, LookAt:=xlWhole).Column
    On Error GoTo 0
    
    If mainVendorCol = 0 Or lookupVendorCol = 0 Then
        MsgBox "Missing column headers!", vbExclamation
        Exit Sub
    End If
    
    ' Populate dictionary with unique lookup vendors
    lastRowLookup = wsLookup.Cells(wsLookup.Rows.Count, lookupVendorCol).End(xlUp).Row
    For i = 2 To lastRowLookup
        Dim vendorVal As String
        vendorVal = Trim(wsLookup.Cells(i, lookupVendorCol).Value)
        If vendorVal <> "" And Not lookupDict.Exists(vendorVal) Then
            lookupDict.Add vendorVal, True
        End If
    Next i
    
    ' Speed up execution
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Loop backwards to avoid skipping rows after deletion
    lastRowMain = wsMain.Cells(wsMain.Rows.Count, mainVendorCol).End(xlUp).Row
    For i = lastRowMain To 2 Step -1
        If lookupDict.Exists(Trim(wsMain.Cells(i, mainVendorCol).Value)) Then
            wsMain.Rows(i).Delete
        End If
    Next i
    
    ' Restore settings
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Batch deletion complete!", vbInformation
End Sub

Key notes: #

• Dictionary lookups: Checking if a vendor exists in the dictionary is instant, unlike looping through the lookup sheet every time.
• Backwards loop: Critical when deleting rows—if you loop forward, deleting a row shifts the rows below up, so you'll skip the next row.
• Trimmed values: Handles accidental spaces in vendor names to ensure accurate matches.

内容的提问来源于stack exchange，提问作者Stryker