Excel VBA优化周期

我很抱歉，如果已经存在类似的问题，但如果是的话，我没有find。

我是VBA编程的新手，现在还不太了解，现在我试着运行一个函数来validation在列“B”中是否有重复的velores，如果存在，将会在列“C”其中最高的值，将最低值复制到另一个表并删除它。

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

我的问题是，如果有什么方法来优化我正在使用的循环，最好使用For Each或保持Do While Loop？

这是我正在使用的代码：

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环境解决scheme，似乎没有什么可以继续走向最佳路线的途径。 下面使用一对Scripting.Dictionaries从Sheet1中的原始matrix构build两组数据。 除了主要的子程序之外，还有两个简短的“帮助程序”函数，它们违反了Application.Index和Application.Transpose遭受的65536的障碍。 这些对于从大的二维数组中剥离出一行是必要的，并且在同时分割存储的logging的同时翻转结果的方向。

 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的数据区域。

我在75000行的列A到列AQ上testing了这个数据，它包含随机样本数据，首先在B列中有重复值，然后在列B中有大约一半的重复值。第一个单一通道在13.19秒内处理; 第二个在14.22。 虽然你自己的结果将取决于你正在运行它的机器，我希望你的原始代码有显着的改善。 如果可以的话，将您自己的计时结果（在VBE的立即窗口内按Ctrl + G开始和停止）写入注释。

Answer 2

通常，在循环结束时执行单个删除操作会更快。

未经testing：

 Function Copy() Dim shtSrc As Worksheet, shtDest As Worksheet Dim lRow As Long, Row As Long, viewmode Dim countA As Long, countB As Long Dim t As Double, rw As Range, rngDel As Range lRow = 5000 Row = 2 countA = 0 countB = 0 Set shtSrc = Worksheets("Sheet1") Set shtDest = Worksheets("Sheet2") shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1") Application.ScreenUpdating = False viewmode = ActiveWindow.View ActiveWindow.View = xlNormalView Application.EnableEvents = False Application.DisplayStatusBar = False ActiveSheet.DisplayPageBreaks = False t = Timer Do While lRow > 2 Set rw = shtSrc.Rows(lRow) If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then rw.Offset(-1, 0).Copy shtDest.Rows(Row) AddToRange rngDel, rw.Offset(-1, 0) countA = countA + 1 Else rw.Copy shtDest.Rows(Row) AddToRange rngDel, rw countB = countB + 1 End If Row = Row + 1 End If lRow = lRow - 1 Loop 'anything to delete? If Not rngDel Is Nothing Then rngDel.Delete End If Application.DisplayStatusBar = True ActiveWindow.View = viewmode Application.ScreenUpdating = False MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60 End Function 'utility sub for building up a range Sub AddToRange(rngTot, rng) If rngTot Is Nothing Then Set rngTot = rng Else Set rngTot = Application.Union(rng, rngTot) End If End Sub