vba - Excel VBA 优化周期

Question

如果已经存在类似的问题，我深表歉意，但如果是，我没有找到。

我是 VBA 编程新手，但仍然不太了解，现在我正在尝试运行一个函数，该函数将验证列“B”中是否重复 velores，如果存在将检查列“C”其中最高值，将最低值复制到另一个表并删除它。

代码已经完成了所有这一切，但是需要在 65 000 行的表中运行，并且需要很长时间，但从来没有运行这些表，因为即使我在 5000 或 10000 行的表中运行也需要大约 6 到 15 分钟。

我的问题是，是否有任何方法可以优化我正在使用的循环，最好使用 For Each 或维护 Do While 循环？

这是我正在使用的代码:

Function Copy()

    Worksheets("Sheet1").Range("A1:AQ1").Copy _
    Destination:=Worksheets("Sheet2").Range("A1")

    Dim lRow As Long
    Dim lRow2 As Long
    Dim Row As Long
    Dim countA As Long
    Dim countB As Long
    Dim t As Double

    lRow = 5000
    Row = 2
    countA = 0
    countB = 0

    Application.ScreenUpdating = False 
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    Application.EnableEvents = False
    Application.DisplayStatusBar = False

    ActiveSheet.DisplayPageBreaks = False
    lRow2 = lRow - 1
    t = Timer

     Do While lRow > 2


            If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then 

                lRow = lRow - 1
                lRow2 = lRow - 1

            Else

                If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then 

                    Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row)
                    Rows(lRow2).Delete 
                    lRow = lRow - 1
                    Row = Row + 1
                    countA = countA + 1


                Else

                    Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row)
                    Rows(lRow).Delete 
                    lRow = lRow - 1
                    Row = Row + 1
                    countB = countB + 1

                End If

                lRow2 = lRow2 - 1

           End If

    Loop

    Application.DisplayStatusBar = True
    ActiveWindow.View = ViewMode
    Application.ScreenUpdating = False 
    MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60

End Function

Answer 1

只要您已进入 VBA 环境以寻求解决方案，那么不继续朝着可能的最佳路线迈进似乎没有什么意义。下面使用一对 Scripting.Dictionaries 从 Sheet1 中的原始矩阵构建两组数据。除了主子程序之外，还有两个简短的“辅助”函数可以突破 Application.Index 的 65536 障碍。和 Application.Transpose受苦。这些对于从大型二维数组中剥离一行并翻转结果的方向，同时拆分存储的记录是必要的。

Sub Keep_Highest_BC()
    Dim d As Long, dHIGHs As Object, dDUPEs As Object
    Dim v As Long, vTMPs() As Variant, iCOLs As Long

    Debug.Print Timer
    'On Error GoTo bm_Safe_Exit
    Set dHIGHs = CreateObject("Scripting.Dictionary")
    Set dDUPEs = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet1")
        iCOLs = .Columns("AQ").Column
        .Cells(1, 1).Resize(2, iCOLs).Copy _
          Destination:=Worksheets("Sheet2").Cells(1, 1)
        With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs)
            vTMPs = .Value2
        End With
    End With

    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
        If dHIGHs.exists(vTMPs(v, 2)) Then
            If CDbl(Split(dHIGHs.Item(vTMPs(v, 2)), ChrW(8203))(2)) < vTMPs(v, 3) Then
                dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=dHIGHs.Item(vTMPs(v, 2))
                dHIGHs.Item(vTMPs(v, 2)) = joinAtoAQ(vTMPs, v)
            Else
                dDUPEs.Add Key:=vTMPs(v, 2) & v, Item:=joinAtoAQ(vTMPs, v)
            End If
        Else
            dHIGHs.Add Key:=vTMPs(v, 2), Item:=joinAtoAQ(vTMPs, v)
        End If
    Next v

    With Worksheets("Sheet1")
        With .Cells(2, 1).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 1, iCOLs)
            .ClearContents
            With .Resize(dHIGHs.Count, iCOLs)
                .Value = transposeSplitLargeItemArray(dHIGHs.items)
            End With
        End With
    End With

    With Worksheets("Sheet2")
        With .Cells(1, 1).CurrentRegion.Offset(1, 0)
            .ClearContents
            With .Resize(dDUPEs.Count, iCOLs)
                .Value = transposeSplitLargeItemArray(dDUPEs.items)
                .Rows(1).Copy
                .PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
            End With
        End With
    End With

bm_Safe_Exit:
    dHIGHs.RemoveAll: Set dHIGHs = Nothing
    dDUPEs.RemoveAll: Set dDUPEs = Nothing

    Debug.Print Timer
End Sub

Function joinAtoAQ(vTMP As Variant, ndx As Long)
    Dim sTMP As String, v As Long

    For v = LBound(vTMP, 2) To UBound(vTMP, 2)
        sTMP = sTMP & vTMP(ndx, v) & ChrW(8203)
    Next v
    joinAtoAQ = Left$(sTMP, Len(sTMP) - 1)
End Function

Function transposeSplitLargeItemArray(vITMs As Variant)
    Dim v As Long, w As Long, vTMPs As Variant, vITM As Variant

    ReDim vTMPs(LBound(vITMs) To UBound(vITMs), LBound(vITMs) To UBound(Split(vITMs(LBound(vITMs)), ChrW(8203))))
    For v = LBound(vITMs) To UBound(vITMs)
        vITM = Split(vITMs(v), ChrW(8203))
        For w = LBound(vITM) To UBound(vITM)
            vTMPs(v, w) = vITM(w)
        Next w
    Next v

    transposeSplitLargeItemArray = vTMPs
End Function

一旦两个字典都填充了最大值并复制了较小的值，这些数组就会被整体返回到两个工作表中，然后又分成 43 列。最后一项努力是将Sheet1 的原始格式恢复到Sheet2 的数据区域。

I tested this on 75,000 rows of columns A through column AQ containing random sample data first with predominantly duplicate values in column B and then with roughly half duplicate values in column B. The first single pass was processed in 13.19 seconds; the second in 14.22. While your own results will depend on the machine you are running it on, I would expect a significant improvement over your original code. Post your own timed results (start and stop in seconds within the VBE's Immediate window, Ctrl+G) into the comments if you can.