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
将目标值存储在数组2中
遍历第一个数组并检查它是否存在于第二个数组中。如果存在，请将其清除
清除sheet1中的搜索值
将数组输出到sheet1
对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

在Excel中优化此VBA查找循环

2 个答案: