Rebecca
09-28-2017, 01:02 AM
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
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