VBA：好奇地减慢了跨页操作的macros（对于7k行需要15分钟！）
我有一个两张表的Excel文件，即; Material Sheet和Resultant Sheet ，其中后者是结果的空白表。 在Material Sheet我有材料信息以及移动代码。 至于架构：
columnA has MaterialCodes & columnG has MovementCodes
现在，对于每种材料，移动代码集（101,102,201,202,241,242,261,262,561）中可能有多行具有不同的移动代码。 我需要检查应用以下逻辑：
从
Material Sheet复制材料的所有行并粘贴到结果表格中，
如果（对于这种材料> 202 =对于这种材料的计数为-202）和（对于这种材料的计数> =对于计数为241的计数）这个材料）和（为这个材料262计数> =这个材料261计数）
目前，我有以下代码（post结尾）。 在此过程中，它将过滤有效的物料代码，并将这些代码存储在“结果表”中（而不是整行）！
我想要的是：
- 我需要修改它，以便每个过滤的材料的所有whole_rows应复制到结果表。
- 现有的代码花费了大约7000分钟的时间（如15分钟）。 非常慢！
FilterWRTMovement是主要的驱动程序。 它调用collectUniqueMaterials函数来收集从columnA到collectionUniqueMaterials数组的唯一材质。 然后，对于每一种独特的材料，它收集材料表的列-g的运动代码，并在FilterValues函数中检查上述逻辑。
Sub FilterWRTMovement() Application.ScreenUpdating = False Dim collectionUniqueMaterials() As String Dim LRow As Long, counter1 As Long, counter2 As Long Dim result(10000) As String, movementOfOneMaterial() As String, current As String Dim has202 As Boolean, has242 As Boolean, has262 As Boolean Dim Destination As Worksheet LRow = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row c = collectUniqueMaterials(collectionUniqueMaterials, LRow) counter1 = 0 counter2 = 0 Set Destination = Worksheets("Resultant Sheet") With ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & LRow) .EntireRow.Hidden = False For Each i In collectionUniqueMaterials i = Trim(i) ReDim movementOfOneMaterial(200) As String has202 = True has242 = True has262 = True counter1 = 0 For j = 1 To .Rows.Count current = Trim(Cells(j, 1)) If current = i Then movementOfOneMaterial(counter1) = Cells(j, 7) counter1 = counter1 + 1 End If Next j FilterValues movementOfOneMaterial, has202, has242, has262 If has202 = True And has242 = True And has262 = True Then result(counter2) = i counter2 = counter2 + 1 End If Erase movementOfOneMaterial Next i End With Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result) 'For Each tup In result 'FindMe (tup) 'Next tup End Sub Function collectUniqueMaterials(ByRef collection() As String, ByRef last As Long) Dim tmp As String myselect = ActiveWorkbook.Worksheets("Material Sheet").Range("A2:A" & last) For Each cell In myselect If (cell <> "") And (InStr(tmp, cell) = 0) Then tmp = tmp & cell & "|" End If Next cell If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1) collection = Split(tmp, "|") End Function Function FilterValues(ByRef sarrCodes() As String, ByRef has202 As Boolean, ByRef has242 As Boolean, ByRef has262 As Boolean) Dim a As Long Dim vKey As Variant Dim objDic As Object Set objDic = CreateObject("Scripting.Dictionary") For a = LBound(sarrCodes) To UBound(sarrCodes) If objDic.Exists(sarrCodes(a)) Then objDic.Item(sarrCodes(a)) = objDic.Item(sarrCodes(a)) + 1 Else objDic.Add sarrCodes(a), 1 End If Next a If objDic.Exists("201") And objDic.Item("201") <> "" Then has202 = False If objDic.Exists("202") And objDic.Item("202") <> "" And objDic.Item("202") >= objDic.Item("201") Then has202 = True End If ElseIf objDic.Exists("241") And objDic.Item("241") <> "" Then has242 = False If objDic.Exists("242") And objDic.Item("242") <> "" And objDic.Item("242") >= objDic.Item("241") Then has242 = True End If ElseIf objDic.Exists("261") And objDic.Item("261") <> "" Then has262 = False If objDic.Exists("262") And objDic.Item("262") <> "" And objDic.Item("262") >= objDic.Item("261") Then has262 = True End If End If End Function
你的帮助将不胜感激。
编辑
结合iDevelp，Issun＆Nick Hebb的build议后，执行30秒后的代码
Sub FilterWRTMovement() Application.ScreenUpdating = False Dim collectionUniqueMaterials() As String, result(10000) As String, movementOfOneMaterial() As String, current As String Dim LRow As Long, counter1 As Long, counter2 As Long Dim has202 As Boolean, has242 As Boolean, has262 As Boolean Dim Destination As Worksheet Dim materialArray As Variant, movementArray As Variant LRow = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row c = collectUniqueMaterials(collectionUniqueMaterials, LRow) counter1 = 0 counter2 = 0 Set Destination = Worksheets("Resultant Sheet") materialArray = Worksheets("Material Sheet").Range("A2:A" & LRow) movementArray = Worksheets("Material Sheet").Range("G2:G" & LRow) For Each i In collectionUniqueMaterials i = Trim(i) ReDim movementOfOneMaterial(200) As String has202 = True has242 = True has262 = True counter1 = 0 For j = 1 To LRow - 1 current = materialArray(j, 1) If current = i Then movementOfOneMaterial(counter1) = movementArray(j, 1) counter1 = counter1 + 1 End If Next j FilterValues movementOfOneMaterial, has202, has242, has262 If has202 = True And has242 = True And has262 = True Then result(counter2) = i counter2 = counter2 + 1 End If Erase movementOfOneMaterial Next i Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result) 'For Each tup In result 'FindMe (tup) 'Next tup End Sub
现在，不是保存结果表（ Destination.Range("A1").Resize(10000, 1).Value = Application.Transpose(result) ）中唯一的材料代码，复制所有行的优化方法是什么从“材料Sheeet”对result数组的每个值（给定：对于结果元素的每个值，在材料表中有多个行，我希望他们都获得过滤的数据）
更新在Tim的post中稍微调整一下，我就可以在一秒钟内达到预期的效果。 以下是VBA脚本：
Sub FilterMaterialWRTMovement() Const SourceSheet As String = "Material Sheet" Const DestinationSheet As String = "Resultant Sheet" Const COL_ID As Integer = 1 Const COL_MOVE As Integer = 7 Dim dict As Object Dim data As Variant, data2(), numRows As Long, numCols As Long Dim r As Long, c As Long Dim shtSrc As Worksheet, shtDest As Worksheet Dim id, mv, arrMv, pos, tmp Dim data2Row As Long Dim firstPass As Boolean Set dict = CreateObject("Scripting.Dictionary") 'movement codes to count arrMv = Array(201, 202, 241, 242, 261, 262) Set shtSrc = ActiveWorkbook.Sheets(SourceSheet) Set shtDest = ActiveWorkbook.Sheets(DestinationSheet) shtDest.Cells.Clear data = shtSrc.Range(shtSrc.Range("A2"), _ shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 10)).Value numRows = UBound(data, 1) numCols = UBound(data, 2) ReDim data2(1 To numRows, 1 To numCols) data2Row = 1 firstPass = True runAgain: For r = 1 To numRows id = data(r, COL_ID) If firstPass Then 'collecting counts... mv = data(r, COL_MOVE) If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0) pos = Application.Match(mv, arrMv, 0) If Not IsError(pos) Then tmp = dict(id) If id = 7024113 Then cwe = 1 End If tmp(pos - 1) = tmp(pos - 1) + 1 dict(id) = tmp End If 'firstPass = False Else 'copying rows tmp = dict(id) If (tmp(0) <> 0) Or (tmp(2) <> 0) Or (tmp(4) <> 0) Then If Not ((tmp(0) <> 0 And tmp(1) < tmp(0)) Or (tmp(2) <> 0 And tmp(3) < tmp(2)) Or (tmp(4) <> 0 And tmp(5) < tmp(4))) Then For c = 1 To numCols data2(data2Row, c) = data(r, c) Next c data2Row = data2Row + 1 End If End If End If Next r If firstPass Then Beep firstPass = False GoTo runAgain Else shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2 End If End Sub
非常感谢你们！
已经很好解决，但这是另一种方法。 如果可以提供的话，我会有兴趣尝试真实的数据。在我的testing中：85k行大概是3-4秒
Sub FilterAndCopyRows() Const COL_ID As Integer = 1 Const COL_MOVE As Integer = 7 Dim dict As New Scripting.dictionary Dim data As Variant, data2(), numRows As Long, numCols As Long Dim r As Long, c As Long Dim shtSrc As Worksheet, shtDest As Worksheet Dim id, mv, arrMv, pos, tmp Dim data2Row As Long Dim firstPass As Boolean 'movement codes to count arrMv = Array(201, 202, 241, 242, 261, 262) Set shtSrc = ActiveWorkbook.Sheets("Material Sheet") Set shtDest = ActiveWorkbook.Sheets("Resultant Sheet") data = shtSrc.Range(shtSrc.Range("A2"), _ shtSrc.Cells(Rows.Count, 1).End(xlUp).Offset(0, 6)).Value numRows = UBound(data, 1) numCols = UBound(data, 2) ReDim data2(1 To numRows, 1 To 7) data2Row = 1 firstPass = True runAgain: For r = 1 To numRows id = data(r, COL_ID) If firstPass Then 'collecting counts... mv = data(r, COL_MOVE) If Not dict.Exists(id) Then dict.Add id, Array(0, 0, 0, 0, 0, 0) pos = Application.Match(mv, arrMv) If Not IsError(pos) Then tmp = dict(id) tmp(pos - 1) = tmp(pos - 1) + 1 dict(id) = tmp End If Else 'copying rows tmp = dict(id) If (tmp(1) > tmp(0)) And (tmp(3) > tmp(2)) And (tmp(5) > tmp(4)) Then For c = 1 To numCols data2(data2Row, c) = data(r, c) Next c data2Row = data2Row + 1 End If End If Next r If firstPass Then Beep firstPass = False GoTo runAgain Else shtDest.Cells(2, 1).Resize(numRows, numCols).Value = data2 End If End Sub
是哪个版本的Excel？ 如果2007年或2010年，罪魁祸首可能是For j = 1 To .Rows.Count ，工作了很多不必要的细胞。
你可以尝试使用
For Each c In Range("a:a").SpecialCells(xlCellTypeConstants)来代替。
两点意见：
（正如iDevelop提到的）.Rows.Count会增加很多不必要的开销。 另外，是不是已经设置到最后一个行号？
另外，如果我正确读取代码，则将值添加到数组中，然后在FilterValues子中对它们进行计数。 难道不可能把它们添加到一个字典，并增加它们在一个传递，而不是有嵌套的循环，并调用FilterValues？
在看到vulcan乌鸦的评论我张贴这些答案
因此，无论何时单元格或单元格区域的内容发生更改，都将重新计算依赖于它们的公式和易失性函数。 您可以使用closures自动计算
Application.Calculation = xlCalculationManual 'turn off the automatic calc 'your code goes here Application.Calculation = xlCalculationAutomatic 'turn On the automatic calc
检查出这些链接在vba优化
http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
http://www.cpearson.com/excel/optimize.htm
也不要使用
if a = "" or a = "" 'thats not good way to do
尝试使用inbulit关键字vbnullstring ，也检查出这些链接进行string优化
http://www.aivosto.com/vbtips/stringopt.html （由brettdjbuild议）。
它会给你很多关于string优化的知识。
希望你今天学到了新东西:)。 谢谢