Copying ranges from multiple Excel sheets into a main sheet

Question

I have a VBA code which copies same data from Multiple sheet and then paste it in "Main" Sheet. It then auto fills the blank cells for values from above and then it delete all the rows Where H:H is blank. However being novice in VBA, i feel my code has too many loops, which makes it run slower. Moreover if have the "Main" Sheet have a table formatted, the code does not delete any row H is blank. However it works if "Main" is blank and not formatted.

Another thing I found out that after the code is executed, the excel sheet becomes less responsive. I cannot select cells quickly, change between sheets.

Please advise if anything can be improved to make it run more efficiently.

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
 Application.CutCopyMode = False
 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

Answer 1

try replacing your copies with this. Does this improve performance?

 DestSh.Cells(Last + 1, "A").Resize(CopyRng1.Rows.Count, CopyRng1.Columns.Count).Value = CopyRng1.Value
 DestSh.Cells(Last + 1, "B").Resize(CopyRng2.Rows.Count, CopyRng2.Columns.Count).Value = CopyRng2.Value
 DestSh.Cells(Last + 1, "C").Resize(CopyRng3.Rows.Count, CopyRng3.Columns.Count).Value = CopyRng3.Value
 DestSh.Cells(Last + 1, "D").Resize(CopyRng4.Rows.Count, CopyRng4.Columns.Count).Value = CopyRng4.Value
 DestSh.Cells(Last + 1, "E").Resize(CopyRng5.Rows.Count, CopyRng5.Columns.Count).Value = CopyRng5.Value
 DestSh.Cells(Last + 1, "F").Resize(CopyRng6.Rows.Count, CopyRng6.Columns.Count).Value = CopyRng6.Value
 Last = LastRow(DestSh)
 DestSh.Cells(Last + 1, "F").Resize(CopyRng7.Rows.Count, CopyRng7.Columns.Count).Value = CopyRng7.Value