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]

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 #?

I also need to incorporate below code as it deletes blank rows in source data

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

 

[Dokat]

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

Ok

 

[mumps]

I also need to incorporate below code as it deletes blank rows in source data

This line of code deletes the blank rows in the Summary:

Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 

[Dokat]

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

The issue is there are blank rows in source data that needs to be removed before pasting. I think that's what's causing the row misalignment.

 

[Dokat]

This line of code deletes the blank rows in the Summary:

Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Thank you it works however it copies column e starting row 1 and column a row 2. There is misalignment where the data starts and ends Please see attached screenshot.

 

[mumps]

Did you put headers in A3 and E3?

 

[mumps]

Replace this line of code:

Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

with this one:

Range("E4", Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 

[Dokat]

Replace this line of code:

Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

with this one:

Range("E4", Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Thank you .Just saw your message it works flawlessly!

 

[Dokat]

Replace this line of code:

Columns("E:E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

with this one:

Range("E4", Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

How can I replicate same process and also copy paste AG25:AG60 from every worksheet. and copy paste O18 to column D and copy paste AG21 to column B.

 

[mumps]

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")