Looping through code

[Rebecca]

Hi All

I hope you can help. I'm a bit of a novice with VBA so I've written a really clunky piece of code to transfer rows of data into a different format on a separate tab. There's about 300 rows at the moment, but that is growing daily and my code takes about 5 mins to run!


Can anyone help me tidy this up?


Sub Run_Cost_Report()

Application.ScreenUpdating = False

Dim LR As Long, i As Long, j As Long

Sheets("For Cost Report").Range("C12:I65536").ClearContents
Sheets("For Cost Report").Range("K12:M65536").ClearContents

With Sheets("Change")
LR = .Range("C" & Rows.Count).End(xlUp).Row

For i = 12 To LR
For j = 1 To 5
.Range("C" & i & ":E" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Range("I" & i & ":I" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(0, 3).PasteSpecial xlPasteValues
.Range("K" & i & ":L" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(0, 4).PasteSpecial xlPasteValues
.Range("N" & i & ":N" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(0, 6).PasteSpecial xlPasteValues
.Range("AE" & i & ":AE" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(0, 10).PasteSpecial xlPasteValues
Next j
.Range("R" & i & ":S" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(-4, 8).PasteSpecial xlPasteValues
.Range("T" & i & ":U" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(-3, 8).PasteSpecial xlPasteValues
.Range("V" & i & ":W" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(-2, 8).PasteSpecial xlPasteValues
.Range("X" & i & ":Y" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(-1, 8).PasteSpecial xlPasteValues
.Range("Z" & i & ":AA" & i).Copy
Sheets("For Cost Report").Range("C" & Rows.Count).End(xlUp).Offset(0, 8).PasteSpecial xlPasteValues
Next i

End With

Application.ScreenUpdating = True

End Sub

Thanks in advance

[mdmackillop]

Hi Rebecca
Can you post some sample data Go Advanced / Manage Attachments. Also when you post code use Code Tags or the # button

[Bob Phillips]

Is this any quicker


Sub Run_Cost_Report()
Dim ws As Worksheet
Dim wsLast As Long
Dim wsStart As Range
Dim LR As Long, i As Long, j As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set ws = Sheets("For Cost Report")
ws.Range("C12:I65536").ClearContents
ws.Range("K12:M65536").ClearContents
Set wsStart = ws.Range("C" & ws.Rows.Count).End(xlUp)

With Sheets("Change")

LR = .Range("C" & .Rows.Count).End(xlUp).Row

For i = 12 To LR

.Range("C" & i & ":E" & i).Copy
wsStart.Offset(i, 0).Resize(5).PasteSpecial xlPasteValues
.Range("I" & i & ":I" & i).Copy
wsStart.Offset(i - 1, 3).Resize(5).PasteSpecial xlPasteValues
.Range("K" & i & ":L" & i).Copy
wsStart.Offset(i - 1, 4).Resize(5).PasteSpecial xlPasteValues
.Range("N" & i & ":N" & i).Copy
wsStart.Offset(i - 1, 6).Resize(5).PasteSpecial xlPasteValues
.Range("AE" & i & ":AE" & i).Copy
wsStart.Offset(i - 1, 10).Resize(5).PasteSpecial xlPasteValues

.Range("R" & i & ":S" & i).Copy
wsStart.Offset(i - 1 - 4, 8).PasteSpecial xlPasteValues
.Range("T" & i & ":U" & i).Copy
wsStart.Offset(i - 1 - 3, 8).PasteSpecial xlPasteValues
.Range("V" & i & ":W" & i).Copy
wsStart.Offset(i - 1 - 2, 8).PasteSpecial xlPasteValues
.Range("X" & i & ":Y" & i).Copy
wsStart.Offset(i - 1 - 1, 8).PasteSpecial xlPasteValues
.Range("Z" & i & ":AA" & i).Copy
wsStart.Offset(i - 1, 8).PasteSpecial xlPasteValues
Next i
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[Rebecca]

Sorry for the lack of tags - I'm new!

I've attached an example of the file I'm working on.

[Rebecca]

Hi xld - unfortunately that code is still running really slowly!

[Bob Phillips]

This is 6 times faster


ub Run_Cost_Report2()
Dim ws As Worksheet
Dim wsLast As Long
Dim wsStart As Range
Dim LR As Long, i As Long, j As Long
Dim mStart As Double

mStart = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set ws = Sheets("Cost Report")
ws.Range("C12:I65536").ClearContents
ws.Range("K12:M65536").ClearContents
Set wsStart = ws.Range("C" & ws.Rows.Count).End(xlUp)

With Sheets("Change")

LR = .Range("C" & .Rows.Count).End(xlUp).Row
j = 1

For i = 12 To LR

.Range("C" & i & ":E" & i).Copy wsStart.Offset(j, 0).Resize(5)
.Range("I" & i & ":I" & i).Copy wsStart.Offset(j, 3).Resize(5)
.Range("K" & i & ":L" & i).Copy wsStart.Offset(j, 4).Resize(5)
.Range("N" & i & ":N" & i).Copy wsStart.Offset(j, 6).Resize(5)
.Range("AE" & i & ":AE" & i).Copy wsStart.Offset(j, 10).Resize(5)

.Range("R" & i & ":S" & i).Copy wsStart.Offset(j, 8)
.Range("T" & i & ":U" & i).Copy wsStart.Offset(j + 1, 8)
.Range("V" & i & ":W" & i).Copy wsStart.Offset(j + 2, 8)
.Range("X" & i & ":Y" & i).Copy wsStart.Offset(j + 3, 8)
.Range("Z" & i & ":AA" & i).Copy wsStart.Offset(j + 4, 8)
j = j + 5
Next i
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Debug.Print Timer - mStart
End Sub

[mdmackillop]

Sub Test()
Dim r, Srce, i, j, k, m
Set sh = Sheets("Change")
Set shCR = Sheets("Cost Report")
With shCR
Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp)).Resize(, 11).ClearContents
End With
Set r = Range(sh.Cells(12, 3), sh.Cells(12, 3).End(xlDown)).Resize(, 29)
Srce = r
arr = shCR.Cells(12, 3).Resize(r.Rows.Count * 5, 11)
For i = 1 To r.Rows.Count
For j = 1 To 5
arr(j + k, 1) = Srce(i, 1)
arr(j + k, 3) = Srce(i, 3)
arr(j + k, 5) = Srce(i, 9)
arr(j + k, 6) = Srce(i, 10)
arr(j + k, 7) = Srce(i, 12)
arr(j + k, 11) = Srce(i, 28)
Next
k = k + 5
Next


k = 0
For i = 1 To r.Rows.Count
m = 1
For j = 1 To 5
arr(j + k, 9) = Srce(i, 15 + m)
arr(j + k, 10) = Srce(i, 16 + m)
m = m + 2
Next
k = k + 5
Next
shCR.Cells(12, 3).Resize(r.Rows.Count * 5, 11) = arr
End Sub

[Rebecca]

That is excellent - thank you so much!