Inefficient code taking too long to run

[Dokat]

Hi,

I have 18 macro codes similar to the one below with different cell ranges . I created a macro that runs all of them in sequence. However it's taking too long to run and very inefficient. Is there a way to speed the run time on this code.

Sub MoveRangeWBC()
Worksheets("WBC").Range("E25:E60").Copy Destination:=Worksheets("Summary").Range("E4")
Worksheets("WBC").Range("W25:W60").Copy Destination:=Worksheets("Summary").Range("F4")
Worksheets("WBC").Range("E25:E60").Copy Destination:=Worksheets("Summary").Range("E40")
Worksheets("WBC").Range("AB25:AB60").Copy Destination:=Worksheets("Summary").Range("F40")

Dim iCntr
Dim rng As Range
Set rng = Worksheets("Summary").Range("A4:F1111")

For iCntr = rng.Row + rng.Rows.Count - 1 To rng.Row Step -1

If Application.WorksheetFunction.CountA(Rows(iCntr)) = 0 Then Rows(iCntr).EntireRow.Delete

Next
With Worksheets("WBC")
.Range("W22").Copy Destination:=Worksheets("Summary").Range("A4:A34")
.Range("AB22").Copy Destination:=Worksheets("Summary").Range("A35:A65")
.Range("O18").Copy Destination:=Worksheets("Summary").Range("D4:D65")


End With

End Sub

 

[Dokat]

Pleas

Into which column do you want to paste AG25:AG60? This line of code already copies O18 into column D:

.Cells(.Rows.Count, "D").End(xlUp).Offset(1).Resize(62).Value = ws.Range("O18")

Please disregard, i created a new sub and modified the range and it seems to be working. Thanks

Sub CopyTarget()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, ws As Worksheet
    Set desWS = Sheets("Summary")
    For Each ws In Sheets
        If ws.Name <> "ST" And ws.Name <> "Summary" Then
            With desWS
                ws.Range("E25:E60").Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
                ws.Range("AG25:AG60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                                
                Range("E4", Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("AG22")
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Resize(31).Value = ws.Range("O18")
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(31).Value = ws.Range("AG21")

                    
               End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[mumps]

My pleasure.