在 Excel 中优化此 VBA 查找循环

Question

我想优化以下代码，因为它很慢。 我正在使用此答案中的代码： https://stackoverflow.com/a/27108055/1042624

但是，循环通过 +10k 行时速度非常慢。是否可以在下面优化我的代码？我试着修改了一下，但似乎没有用。

Sub DeleteCopy2()

Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long

Application.ScreenUpdating = False
Application.Calculation = xlManual

strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1

LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row

ReDim arrVal(2 To LastRow) ' Headers in row 1

For CurRow = LBound(arrVal) To UBound(arrVal)
    If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        Sheets("MatchData").Range("A" & CurRow).Value = ""
    Else
    End If
Next CurRow

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

你能帮我试试这个吗？我已经对代码进行了注释，以便您理解它不会有问题。还要检查 10k+ 行需要多少时间

逻辑

1. 将搜索值存储在数组 1 中
2. 将目标值存储在数组 2 中
3. 遍历第一个数组并检查它是否存在于第二个数组中。如果存在，请将其清除
4. 从 sheet1 中清除搜索值
5. 将数组输出到 sheet1
6. 对 Col A 进行排序，使空白向下。

代码

Sub Sample()
    Dim wbMatch As Worksheet, wbDestSheet As Worksheet
    Dim lRow As Long, i As Long
    Dim MArr As Variant, DArr As Variant
    Dim strSheetName As String
    Dim rng As Range

    strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1

    '~~> Set your worksheets
    Set wbMatch = Sheets("MatchData")
    Set wbDestSheet = Sheets(strSheetName)

    '~~> Store search values in 1st array
    With wbMatch
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set rng = .Range("A2:A" & lRow)
        MArr = rng.Value
    End With

    '~~> Store destination values in the 2nd array
    With wbDestSheet
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        DArr = .Range("A2:A" & lRow).Value
    End With

    '~~> Check if the values are in the other array
    For i = LBound(MArr) To UBound(MArr)
        If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
    Next i

    With wbMatch
        '~~> Clear the range for new output
        rng.ClearContents

        '~~> Output the array to the worksheet
        .Range("A2").Resize(UBound(MArr), 1).Value = MArr

        '~~> Sort it so that the blanks go down
        .Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    End With
End Sub

'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
    Dim j As Long

    For j = 1 To UBound(arr, 1)
        On Error Resume Next
        IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
        On Error GoTo 0
        If IsInArray = True Then Exit For
    Next
End Function

编辑

另一种方式。根据示例文件，此代码运行时间约为 1 分钟。

Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM

逻辑：

它使用CountIf检查重复项，然后使用.Autofilter删除重复项

Sub Sample()
    Dim wbMatch As Worksheet, wbDestSheet As Worksheet
    Dim lRow As Long
    Dim strSheetName As String
    Dim rng As Range

    Debug.Print "Start : " & Now

    strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1

    '~~> Set your worksheets
    Set wbMatch = Sheets("MatchData")
    Set wbDestSheet = Sheets(strSheetName)

    '~~> Store search values in 1st array
    With wbMatch
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        .Columns(2).Insert
        Set rng = .Range("B2:B" & lRow)

        lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row

        rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
        DoEvents

        rng.Value = rng.Value
        .Range("B1").Value = "Temp"

        'Remove any filters
        .AutoFilterMode = False

        With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
            .AutoFilter Field:=2, Criteria1:=">0"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        'Remove any filters
        .AutoFilterMode = False

        .Columns(2).Delete
    End With

    Debug.Print "End : " & Now
End Sub

Answer 2

看起来@SiddarthRout 和我在并行工作......

我下面的代码示例在不到 2 秒（眼球估计）内执行了近 12,000 行。

Option Explicit

Sub DeleteCopy2()
    Dim codeTimer As CTimer
    Set codeTimer = New CTimer
    codeTimer.StartCounter

    Dim thisWB As Workbook
    Dim destSH As Worksheet
    Dim matchSH As Worksheet
    Set thisWB = ThisWorkbook
    Set destSH = thisWB.Sheets("Week 32")
    Set matchSH = thisWB.Sheets("MatchData")

    Dim lastMatchRow As Long
    Dim lastDestRow As Long
    lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
    lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row

    '--- copy working data into memory arrays
    Dim destArea As Range
    Dim matchData As Variant
    Dim destData As Variant
    matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
    Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
    destData = destArea

    Dim i As Long
    For i = 2 To lastDestRow
        If Not InMatchingData(matchData, destData(i, 1)) Then
            destData(i, 1) = ""
        End If
    Next i

    '--- write the marked up data back to the worksheet
    destArea = destData

    Debug.Print "Destination rows = " & lastDestRow
    Debug.Print "Matching rows    = " & lastMatchRow
    Debug.Print "Execution time   = " & codeTimer.TimeElapsed & " secs"
End Sub

Private Function InMatchingData(ByRef dataArr As Variant, _
                                ByRef dataVal As Variant) As Boolean
    Dim i As Long
    InMatchingData = False
    For i = LBound(dataArr) To UBound(dataArr)
        If dataVal = dataArr(i, 1) Then
            InMatchingData = True
            Exit For
        End If
    Next i
End Function

我的代码的计时结果是（使用来自 this post 的计时器类）：

Destination rows = 35773
Matching rows    = 23848
Execution time   = 36128.4913359179 secs