我正在尝试比较两个产品列表。如果从 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 脚本，谢谢。
最佳答案
删除行
基本(两个循环)
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
关于excel - 比较列与范围并在 VBA 中的多个工作表之间删除，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/69541484/