如果已经存在类似的问题，我道歉，但如果是，我找不到。
我刚接触VBA编程并且仍然不太了解它，现在我正在尝试运行一个函数来验证是否在列中＆＃34; B＆＃34;是重复的丝绒，如果存在，将检查一列＆＃34; C＆＃34;最高值，将最低值复制到另一个表并删除它。
代码已经完成所有这些但是需要在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
答案 0 :(得分：1)
只要您已经进入VBA环境寻求解决方案，似乎没有必要继续沿着最佳路线前进。下面使用一对Scripting.Dictionaries从Sheet1中的原始矩阵构建两组数据。除了主要的子程序之外，还有两个简短的帮手＆＃39;破坏Application.Index和Application.Transpose遭受的65536障碍的功能。这些是从大型二维阵列中剥离一行并翻转结果方向同时拆分存储记录所必需的。
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
一旦两个词典填充了最大值和重复较小的值，数组将返回到两个工作表 en masse ，然后拆分回43列。最后的努力是将原始格式从Sheet1恢复到Sheet2的数据区域。
我在包含随机样本数据的75,000行A列到AQ列中进行了测试，首先在B列中主要使用重复值，然后在B列中使用大约一半重复值。第一次单遍在13.19秒内处理; 14.22中的第二个。虽然您自己的结果将取决于您运行它的计算机，但我希望您的原始代码会有显着改进。如果可以的话，将您自己的定时结果（在VBE的立即窗口内以秒开始和停止，按Ctrl + G）发布到注释中。
答案 1 :(得分：0)
通常，在循环结束时执行单个删除会更快。
未测试：
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