我在一個作業簿中使用以下代碼，如下所示：（1）將范圍SheetA與范圍匹配SheetB。(2) 如果在 上找到資料，SheetB,則將在SheetB和上插入一些值Sheet Log。(3) SheetB 上匹配的資料（行）將被復制到 Autofit 中Sheet Result。(4) SheetB 上的匹配資料（行）將是cleared.（剪切和粘貼不適用）。SheetA 中第一個范圍的值的計數通常為 7 或 8，并且此宏的速度與完成所有這些步驟所需的時間一樣快。我嘗試在第一個范圍內設定 146 個值，但宏變得非常慢，需要 35 秒才能完成。請問，如何加速和優化這個宏？
注意：更改匹配代碼或復制、粘貼、自動調整和清除代碼完全沒有問題。
第一條評論的完整宏和作業表的鏈接。
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
uj5u.com熱心網友回復：
請檢查下一個改編的代碼。它使用陣列來實作更快的迭代和更快的結果回傳。此外，為每個單元格設定行高會消耗 Excel 資源。我評論了一些行，但現在沒有時間做所有事情。如果有不清楚的地方，請隨時要求澄清：
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k 1
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
End If
'Clearing the temporary filled range in the iterated sheet:
ws.Range("G2:I" & lastR).ClearContents
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
應該不到一秒...
uj5u.com熱心網友回復：
您的問題的根源是您正在對作業表進行許多編輯。加速 VBA 代碼的首要方法之一是減少將資料寫入作業表的次數。
For Each與其每次都在回圈中將資料寫入作業表，不如將所有資料添加到一個Array，然后Array一次將整個資料寫入作業表。這樣，您不必為每個For Each回圈撰寫多次，而只需撰寫一次。
我不能保證這是您的代碼“次優”的唯一原因，但它是開始提高性能時間的好地方。
uj5u.com熱心網友回復：
雖然寫入作業表確實需要時間，但這里的主要問題是復制/粘貼部分。
如果你，后排
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
放一些類似的東西：
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
然后完全洗掉復制/粘貼部分，您應該幾乎可以立即運行它。
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/413786.html
標籤：