excel - VBA 代码有太多循环，导致运行速度变慢

Question

我有一个 VBA 代码，它从多个工作表中复制相同的数据，然后将其粘贴到“主”工作表中。然后它自动填充上面的值的空白单元格，然后删除 H:H 为空白的所有行。然而，作为 VBA 的新手，我觉得我的代码有太多循环，这使得它运行得更慢。此外，如果“主”表有一个表格格式，代码不会删除任何行H为空白。但是，如果“Main”为空白且未格式化，则它可以工作。

我发现的另一件事是，在执行代码后，excel 工作表的响应速度变慢了。我无法快速选择单元格，在工作表之间切换。

请告知是否可以改进以使其更有效地运行。

Private Sub CopyRangeFromMultiWorksheets1()



'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")

Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long



With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
 Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"

'loop through all worksheets and copy the data to the DestSh
 For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <> 
  "TECHTeamList" Then

        'Find the last row with data on the DestSh
        Last = LastRow(DestSh)

        'Fill in the range that you want to copy
        Set CopyRng1 = sh.Range("B3")
        Set CopyRng2 = sh.Range("C3")
        Set CopyRng3 = sh.Range("D3")
        Set CopyRng4 = sh.Range("G3")
        Set CopyRng5 = sh.Range("C5")
        Set CopyRng6 = sh.Range("A8:j25")
        Set CopyRng7 = sh.Range("A28:j45")

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If

        'This example copies values/formats, if you only want to copy the
        'values or want to copy everything look at the example below this 
  macro
        CopyRng1.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        CopyRng2.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        CopyRng3.Copy
        With DestSh.Cells(Last + 1, "C")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With

         CopyRng4.Copy
        With DestSh.Cells(Last + 1, "D")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False

        End With
         CopyRng5.Copy
        With DestSh.Cells(Last + 1, "E")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With


        CopyRng6.Copy
        With DestSh.Cells(Last + 1, "F")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With


        'Refresh the Lastrow used so that the values start from 
        'underneath copyrng6

        Last = LastRow(DestSh)
         CopyRng7.Copy
        With DestSh.Cells(Last + 1, "F")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With


    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
 DestSh.Columns.AutoFit

 'Autofill the rang A2:E for values from above looking at  the last row of F
 With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
 .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With


 'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

任何帮助，将不胜感激。

标签： excelvbaloops