VBA代码循环过多，因此运行速度较慢

Question

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

我发现另一件事是，在执行代码后，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

任何帮助将不胜感激。