vba 复制粘贴宏超慢| 需要优化

Copy Paste Macro is ultra slow | Optimization needed

提问by stefan

Below is my VBA code which is ultra slow (takes around 3 minutes to copy and paste three new rows!). The database itself contains around 10,000 rows and I am not sure whether that is causing that slow performance or whether the code itself is far away from being efficient. It certainly has nothing to do with the hardware rig.

下面是我的 VBA 代码，它非常慢（复制和粘贴三个新行大约需要 3 分钟！）。数据库本身包含大约 10,000 行，我不确定这是导致性能下降还是代码本身离高效很远。它当然与硬件装备无关。

Sub AutomateUserResearch()

Dim rowlast As Long 'letzte benutze Zeile
Dim rowlastexport As Long 'letzte benutze Zeile auf "database" + 1 addieren
Dim rowlastexportfinal As Long 'letzte benutze Zeile auf "database" nach Hinzufügen neuer Zeilen finden
Dim NewRecords As String
Dim i As Integer

Application.ScreenUpdating = False

Calculate
NewRecords = ThisWorkbook.Worksheets("checklist").Range("NewRecordsCheck").Value

With Sheets("csv_import")
    rowlast = .UsedRange.Rows.Count + .UsedRange.Row - 1 'find last used row on "csv_import"

    .Range(.Cells(2, 1), .Cells(rowlast, 1)).Formula = .Cells(2, 1).Formula 'copy down formulas for column A
'    .Range(.Cells(2, 1), .Cells(rowlast, 1)).Select
'        With Selection
'            .Interior.ThemeColor = xlThemeColorAccent4
'        End With
    .Range(.Cells(2, 2), .Cells(rowlast, 2)).Formula = .Cells(2, 2).Formula 'copy down formulas for column B
End With

Sheets("csv_import").Calculate

With Sheets("csv_import")
    rowlast = .UsedRange.Rows.Count + .UsedRange.Row - 1
End With

With Sheets("database")
    rowlastexport = .UsedRange.Rows.Count + 1 + .UsedRange.Row - 1
End With

ActiveWorkbook.Worksheets("csv_import").Activate

If NewRecords = "YES" Then 'only proceed with Sub if Column A on "csv_import" has rows with "new" in it, otherwise Exit Sub as no new records exist
    'MsgBox ("New Records Exist")
    ActiveSheet.Range("A1:S1").AutoFilter Field:=1, Criteria1:="new"
    ActiveSheet.Range("B2 : D" & rowlast).Copy
    Sheets("database").Range("A" & rowlastexport).PasteSpecial
    Sheets("csv_import").Range("A1:S1").AutoFilter Field:=1
    Sheets("csv_import").Calculate
    Sheets("checklist").Calculate
Else:
    MsgBox ("There are no new records to be exported!")
    Exit Sub
End If

With ActiveWorkbook.Worksheets("database")
    rowlastexportfinal = .UsedRange.Rows.Count + 1 + .UsedRange.Row - 1
    For i = 4 To 19 'iterate through column 4 to 19 to copy down formulas and add color
       .Range(.Cells(2, i), .Cells(rowlastexportfinal, i)).Formula = .Cells(2, i).Formula
       .Range(.Cells(2, i), .Cells(rowlastexportfinal, i)).Interior.ColorIndex = 15
    Next i
End With

Sheets("database").Calculate
Sheets("database").Select
Application.ScreenUpdating = True

End Sub 

回答by ARich

I don't see anything glaringly obvious. A few thoughts:

我没有看到任何明显的东西。一些想法：

You might try setting Application.Calculation = xlCalculationManual. That will keep Excel from calculating every time a cell's value changes. If you have a lot of formulas (it seems that you do), calculations can be a real drain on performance.

您可以尝试设置Application.Calculation = xlCalculationManual. 这将阻止 Excel 每次单元格的值更改时进行计算。如果您有很多公式（似乎您有），计算可能会真正消耗性能。

There may be a reason for the way you did this, but you might also try waiting to force calculations until the end of the code and calculate the entire workbook at once.

您这样做可能是有原因的，但您也可以尝试等待强制计算直到代码结束并立即计算整个工作簿。

Anytime you copy something to the clipboard, it drains performance. If you're only concerned with copying values, you can try the Range("A1").Value = Range("B1").Valuemethod of copying values. This will bypass the clipboard and save you some performance.

任何时候您将某些内容复制到剪贴板，都会消耗性能。如果你只关心复制值，你可以尝试Range("A1").Value = Range("B1").Value复制值的方法。这将绕过剪贴板并为您节省一些性能。

If you have any worksheet events, you might try setting Application.EnableEvents = False.

如果您有任何工作表事件，您可以尝试设置Application.EnableEvents = False.

Those are the only things I can think of. Good luck!

我能想到的就只有这些了。祝你好运！