Question

我在同一个工作簿中有2个工作表。如果SourceSheet中的单元格符合某些条件，我想将同一行中的几个非相邻单元格复制到NewSheet。问题是它需要花费半秒钟来粘贴每个单元格，这使得宏太慢了。下面的代码需要8秒才能完成一个循环。我有更快的方法吗？

Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long

'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row

For row = 2 To lrow

With EnrollmentChanges

    course1 = Sheets("SourceSheet").Range("A" & row)

    If course1 <> "" Then
        course1status = Sheets("SourceSheet").Range("BS" & row)
        If InStr(1, course1, "APEX") And course1status = "1" Then
            NewSheetRow = NewSheetRow + 1
            Sheets("NewSheet").Range("A" & NewSheetRow) = NewSheetRow
            Sheets("NewSheet").Range("B" & NewSheetRow) = "W"
            Sheets("NewSheet").Range("C" & NewSheetRow) = "S"
            Sheets("NewSheet").Range("D" & NewSheetRow) = "MySchool"
            Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("G" & NewSheetRow)
            Sheets("SourceSheet").Range("W" & row).Copy Sheets("NewSheet").Range("H" & NewSheetRow)
            Sheets("SourceSheet").Range("V" & row).Copy Sheets("NewSheet").Range("J" & NewSheetRow)
            Sheets("SourceSheet").Range("Y" & row).Copy Sheets("NewSheet").Range("K" & NewSheetRow)
            Sheets("NewSheet").Range("L" & NewSheetRow) = "OR"
            Sheets("SourceSheet").Range("B" & row).Copy Sheets("NewSheet").Range("M" & NewSheetRow)
            Sheets("SourceSheet").Range("A" & row).Copy Sheets("NewSheet").Range("P" & NewSheetRow)
        End If

    Else: GoTo NextRow
    End If 
End With
NextRow:
Next

Answer 1

解决这个问题的最佳方法是完全避免复制和粘贴（这是非常慢的）。复制/粘贴唯一值得保留的时间是您需要复制格式。如果您只需要这些值，那么您可以执行以下操作：

Dim EnrollmentChanges As Range
Dim course1 As Range
Dim course1status As Range
Dim row As Long
Dim lrow As Long
Dim NewSheetRow As Long

'This is a dynamic named range
Set EnrollmentChanges = Sheets("SourceSheet").Range("Source")
NewSheetRow = 0
lrow = Sheets("SourceSheet").Range("A1").End(xlDown).row

For row = 2 To lrow

With EnrollmentChanges

course1 = Sheets("SourceSheet").Range("A" & row)

If course1 <> "" Then
    course1status = Sheets("SourceSheet").Range("BS" & row)
    If InStr(1, course1, "APEX") And course1status = "1" Then
        NewSheetRow = NewSheetRow + 1
        With Sheets("NewSheet")
            .Range("A" & NewSheetRow).Value = NewSheetRow
            .Range("B" & NewSheetRow).Value = "W"
            .Range("C" & NewSheetRow).Value = "S"
            .Range("D" & NewSheetRow).Value = "MySchool"

            .Range("G" & NewSheetRow.Value = Sheets("SourceSheet").Range("B" & row).Value
            .Range("H" & NewSheetRow).Value = Sheets("SourceSheet").Range("W" & row).Value
            .Range("J" & NewSheetRow).Value = Sheets("SourceSheet").Range("V" & row).Value 
            .Range("K" & NewSheetRow).Value = Sheets("SourceSheet").Range("Y" & row).Value 
            .Range("L" & NewSheetRow).Value = "OR"
            .Range("M" & NewSheetRow).Value = Sheets("SourceSheet").Range("B" & row).Value
            .Range("P" & NewSheetRow).Value = Sheets("SourceSheet").Range("A" & row).Value
        End With
    End If

' No need for this since you are skipping the operation using the if block
' GoTo is messy and should be avoided where possible as well.
'Else: GoTo NextRow
End If 
End With
NextRow:
Next

我所做的就是交换订单并根据检索到的值直接分配值，而不是将检索到的值存储为副本，并将其放在新位置。一旦你练习这一点，它会更有意义（并且它会大大加快你的代码）。

如开头所述，如果你需要保留格式，那就有点不同了。

另外，我没有打扰优化或缩进代码中的任何其他元素，但是你需要通过适当的缩进来清理它并跳过诸如＆＃34; GoTo＆＃34;。

之类的东西。

Answer 2

call这个sub是您的宏顶部：

Sub MakeItFaster()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False

End Sub

为什么我的Excel VBA代码复制单元格这么慢？

2 个答案: