宏在近700行上循环需要很长时间

Question

我正试图根据映射(索引I(的条目在一张近700行的纸上循环，循环I的每次迭代都需要很长时间(在j上循环很长时间(。原因是什么？我几乎每天都在写宏，从来没有经历过这个问题。此外，我试图只留下循环j中的第一行，但一直遇到这个问题

业务需求：提取表中C列包含映射表中值的所有列(即满足此条件PacketWork=图纸(图纸名称(。单元格(j，第3列(。值其中列3是"；C"；

For i = 2 To lastRowLevelMapping
PacketWork = Sheets("Mapping").Cells(i, "A").Value

For j = 2 To LastRowSheet

If (PacketWork = Sheets(sheetname).Cells(j, Column3).Value) Then
Sheets("Source").Cells(writer_counter, "A").Value = Sheets(sheetname).Cells(j, Column1).Value

Sheets("Source").Cells(writer_counter, "B").Value = Sheets(sheetname).Cells(j, Column2).Value
Sheets("Source").Cells(writer_counter, "C").Value = Sheets(sheetname).Cells(j, Column3).Value
Sheets("Source").Cells(writer_counter, "D").Value = Sheets(sheetname).Cells(j, Column4).Value
data = Sheets(sheetname).Cells(j, Column5).Value
If (IsNumeric(data)) Then
Sheets("Source").Cells(writer_counter, "E").Value = Round(data, 2)
Else
Sheets("Source").Cells(writer_counter, "E").Value = data
End If
data = Sheets(sheetname).Cells(j, Column6).Value
If (IsNumeric(data)) Then
Sheets("Source").Cells(writer_counter, "F").Value = Round(data, 2)
Else
Sheets("Source").Cells(writer_counter, "F").Value = data
End If
data = Sheets(sheetname).Cells(j, Column7).Value
If (IsNumeric(data)) Then
Sheets("Source").Cells(writer_counter, "G").Value = Round(data, 2)
Else
Sheets("Source").Cells(writer_counter, "G").Value = data
End If
data = Sheets(sheetname).Cells(j, Column8).Value
If (IsNumeric(data)) Then
Sheets("Source").Cells(writer_counter, "H").Value = Round(data, 2)
Else
Sheets("Source").Cells(writer_counter, "H").Value = data
End If
data = Sheets(sheetname).Cells(j, Column9).Value
If (IsNumeric(data)) Then
Sheets("Source").Cells(writer_counter, "I").Value = Round(data, 2)
Else
Sheets("Source").Cells(writer_counter, "I").Value = data
End If


If (IsDate(Sheets(sheetname).Cells(j, Column10).Value)) Then
Sheets("Source").Cells(writer_counter, "P").Value = Format(Sheets(sheetname).Cells(j, Column10).Value, "dd/mm/yyyy")
Else
Sheets("Source").Cells(writer_counter, "P").Value = Sheets(sheetname).Cells(j, Column10).Value
End If
Sheets("Source").Cells(writer_counter, "P").NumberFormat = "dd/mm/yyyy"

If (Sheets("Source").Cells(writer_counter, "E").Value <> 0) Then

Sheets("Source").Cells(writer_counter, "L").Value = Round((Sheets("Source").Cells(writer_counter, "F").Value / Sheets("Source").Cells(writer_counter, "E").Value) * 100, 2)
Sheets("Source").Cells(writer_counter, "M").Value = Round((Sheets("Source").Cells(writer_counter, "G").Value / Sheets("Source").Cells(writer_counter, "E").Value) * 100, 2)
Else
Sheets("Source").Cells(writer_counter, "L").Value = 0
Sheets("Source").Cells(writer_counter, "M").Value = 0

End If

Sheets("Source").Cells(writer_counter, "L").NumberFormat = "0.00"
Sheets("Source").Cells(writer_counter, "M").NumberFormat = "0.00"
If (Sheets("Source").Cells(writer_counter, "L").Value > 100) Then
Sheets("Source").Cells(writer_counter, "L").Value = 100
End If
If (Sheets("Source").Cells(writer_counter, "M").Value > 100) Then
Sheets("Source").Cells(writer_counter, "M").Value = 100
End If
If (Contains(Mapping2Collection, Sheets(sheetname).Cells(j, Column4).Value)) Then
Sheets("Source").Cells(writer_counter, "N").Value = Mapping2Collection(Sheets(sheetname).Cells(j, Column4).Value)
End If
Sheets("Source").Cells(writer_counter, "K").Value = Sheets("Mapping").Cells(i, "D").Value
Sheets("Source").Cells(writer_counter, "J").Value = Sheets("Mapping").Cells(i, "C").Value

Sheets("Source").Cells(writer_counter, "O").Value = Sheets("Mapping").Cells(i, "B").Value


writer_counter = writer_counter + 1



End If
Next j
Next i

Answer 1

将数据读入数组，并用字典查找替换双循环

Option Explicit
Sub transform()

Const SHT_INPUT = "sheetname"
Const SHT_OUTPUT = "Source"
Const SHT_MAPPING = "Mapping"
Dim colMap ' mapping for column1 to column10
colMap = Array(0, 1, 2, 3, 4, 5, 6, 7, 26, 25, 24)
Dim wb As Workbook
Dim wsIn As Worksheet, wsMap As Worksheet, wsOut As Worksheet
Dim arMap(), arIn(), arOut()
Dim iRowOut As Long, iLastRow As Long, iLastCol As Integer
Dim c As Integer, i As Long, n As Long, r As Long
Dim Mapping2Collection As New Collection
Set wb = ThisWorkbook
Set wsIn = wb.Sheets(SHT_INPUT)
Set wsOut = wb.Sheets(SHT_OUTPUT)
Set wsMap = wb.Sheets(SHT_MAPPING)
' build dictionary look up to sheetname column3
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsIn.Cells(Rows.Count, colMap(3)).End(xlUp).Row 'last row
iLastCol = wsIn.Cells(1, Columns.Count).End(xlToLeft).Column 'last column

' copy sheet to array then scan for values in colMap(3)
arIn = wsIn.Range("A1").Resize(iLastRow, iLastCol).Value2
For r = 2 To iLastRow
key = Trim(arIn(r, colMap(3))) ' key in colMap(3)
If dict.exists(key) Then
MsgBox "Duplicate key '" & key & "' at row " & r, vbCritical
Exit Sub
Else
dict.Add key, r
End If
Next
MsgBox dict.Count & " records added to dictionary from sheet " & wsIn.Name, vbInformation
' copy rows on mapping sheet to array
iLastRow = wsMap.Cells(Rows.Count, "A").End(xlUp).Row 'last row
ReDim arMap(iLastRow - 1, 4) ' less header
arMap = wsMap.Range("A2:D" & iLastRow)
' create output
wsOut.Cells.Clear
iRowOut = wsOut.Cells(Rows.Count, "A").End(xlUp).Row + 1 'first empty
n = 0
For i = 1 To UBound(arMap)
key = arMap(i, 1) ' col A Packet Work
Debug.Print i, key
If dict.exists(key) Then
' find row on input sheet matching key
r = dict(key)

' build row
ReDim arOut(1 To 16) ' clear
' col A to I
For c = 1 To 9
arOut(c) = arIn(r, colMap(c))
Next
' col D to I Round 2 dec if numeric
For c = 5 To 9
If IsNumeric(arOut(c)) Then
arOut(c) = Round(arOut(c), 2)
End If
Next
'col J K from mappimg sheet
arOut(10) = arMap(i, 3) ' J = map col C
arOut(11) = arMap(i, 4) ' K = map col D
' col L =F/E and M=G/E % calc
For c = 12 To 13
If IsNumeric(arOut(5)) Then
If arOut(5) = 0 Then
arOut(c) = 0
Else
arOut(c) = Round(100 * arOut(c - 6) / arOut(5), 2)
If arOut(c) > 100 Then arOut(c) = 100
End If
End If
Next
' col N not sure what this is ?
If contains(Mapping2Collection, arOut(4)) Then
arOut(14) = Mapping2Collection(arOut(4))
End If
'col O from mapping sheet col B
arOut(15) = arMap(i, 2) ' O = map col B
' col P from colMap(10) - date
arOut(16) = arIn(r, colMap(10)) ' P
' format line and write out array
With wsOut
.Cells(iRowOut, "L").NumberFormat = "0.00"
.Cells(iRowOut, "M").NumberFormat = "0.00"
.Cells(iRowOut, "P").NumberFormat = "dd/mm/yyyy"

' write array values to output sheet
.Cells(iRowOut, 1).Resize(1, 16) = arOut
End With

' next line
Erase arOut
iRowOut = iRowOut + 1
n = n + 1
End If
Next
' end
wsOut.Activate
wsOut.Columns("A:P").AutoFit
MsgBox n & " rows written to sheet" & wsOut.Name, vbInformation
End Sub
' dummy
Private Function contains(obj As Collection, val) As Boolean
contains = False
End Function

Answer 2

我最喜欢的格言是">不使用Excel，使用数据"；。你需要大量使用Excel——每次迭代都要进行大量的数据读取和数据输入。每个Sheet.Cells.Value = Sheet.Cells.Value进入一个表，一个单元格并读取一个值，然后进入一个图，另一个单元格，并在那里输入值；每个条件也必须读取单元格。这显然需要大量的资源。

根据我的经验，如果你需要做这样的事情，数组就是答案。确定要处理的范围(Excel对象，这会减慢您的速度(，将它们加载到变量类型变量中，然后在数组中执行操作(数据，您想真正处理的数据，加载在内存中(，然后一次性将数组插入回范围中。说明：我们碰巧在工作中就一些密集的数据操作自动化发生了沟通错误，有人在复制同一个自动化项目，但我使用数组和字典完成了整个工作，而另一个人则直接通过工作表引用完成。我每次执行的时间大约是30-45秒。他们的时间是5-6小时。

此外，如果您多次引用相同的坐标，则应该将其放入变量中。它不仅速度更快，而且是一种很好的编码实践，因为当你需要修改代码时，你不需要更改那么多引用，并将忘记一些引用的风险降至最低。