在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. 对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删除重复.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，我正在并行工作...

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

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

从我的代码定时的结果（使用来自计时器类此篇 ）：

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