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

 

[mumps]

Is there any reason why you want to start pasting data in row 4 in the Summary sheet?

 

[Dokat]

I'm sure it will be mentioned but have you considered starting with

Application.Screenupdating = False

and ending with

Application.Screenupdating = True

It still takes quite a bit to run but still tremendously shorten the run time. It took only 10 mins to finish runing.

 

[Dokat]

Is there any reason why you want to start pasting data in row 4 in the Summary sheet?

Yes that's where my header is, but if i need to change is it is not mission critical. However it also means i have to change cell ranges. for all 18 macros.

 

[mumps]

Are you headers in row 3 or row 4?

 

[Dokat]

Headers

Are you headers in row 3 or row 4?

Headers going to be in row 3.

 

[mumps]

OK. Working on it.

 

[mumps]

Try:

Sub CopyRange()
    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("W25:W60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                ws.Range("E25:E60").Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
                ws.Range("AB25:AB60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("W22")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("AB22")
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Resize(62).Value = ws.Range("O18")
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[Dokat]

Try:

Sub CopyRange()
    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("W25:W60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                ws.Range("E25:E60").Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
                ws.Range("AB25:AB60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("W22")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("AB22")
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Resize(62).Value = ws.Range("O18")
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

It works alot faster. Is there a way to combine all 18 macros together?

 

[Dokat]

Try:

Sub CopyRange()
    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("W25:W60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                ws.Range("E25:E60").Copy .Cells(.Rows.Count, "E").End(xlUp).Offset(1)
                ws.Range("AB25:AB60").Copy .Cells(.Rows.Count, "F").End(xlUp).Offset(1)
                Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("W22")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(31).Value = ws.Range("AB22")
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1).Resize(62).Value = ws.Range("O18")
            End With
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

I just realized it copy pasted all values however column E starts from row #1 and column A from row #2 can you both start from same row #?

 

[mumps]

Just make sure that columns A and E have a header in A3 and E3. It can be anything.