CODEWITHSUNDEEP
excelvbaruntime
S.C
S.C

Reputation: 21

Reduce VBA Run Time

I have this file that I need to copy and paste multiple times from one tab to another. I am pretty new to VBA coding, so I give each category a for loop. But it took 35 mins to finish running. The results are correct, but the run time is too long.

I have included screenupdating = False, enableevents = false, and manual calculation in my code. But it doesn't help with the run time.

Sub Copyplans()

Dim cntplan As Integer
Dim tot_year As Integer
Dim tot_quarter As Integer
Dim tot_age As Integer
Dim tot_plan As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim quarter_row As Long
Dim quarter_rows As Long
Dim s1 As Worksheet
Dim s2 As Worksheet 

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual


Set s1 = Sheet1
Set s2 = Sheet2
Set bs = Sheet4
Set bafs = Sheet5
Set s1ope = Sheet6

cntplan = Excel.WorksheetFunction.CountA(s2.Range("A:A")) 
tot_year = cntplan * 66 * 4 
tot_quarter = cntplan * 66 
tot_age = cntplan * 4

'copy current year
For i = 1 To tot_year
s2.Range("Current_year").Copy
s1.Range("A" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy version
For i = 1 To tot_year
s2.Range("version").Copy
s1.Range("C" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy quarter 1 to 4
For i = 1 To 4
   For j = 1 To tot_quarter
   quarter_row = s1.Range("B" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("H" & i).Copy
   s1.Range("B" & quarter_row).PasteSpecial Paste:=xlPasteValues
   Next j
Next i


'copy age 0-65
For i = 1 To tot_age
   For j = 1 To 66
   quarter_row = s1.Range("F" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("K" & j).Copy
   s1.Range("F" & quarter_row).PasteSpecial Paste:=xlPasteValues
   Next j
Next i



'copy IDs
For i = 1 To 4
   For j = 1 To cntplan
     For k = 1 To 66
   quarter_rows = s1.Range("D" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("A" & j).Copy
   s1.Range("D" & quarter_rows).PasteSpecial Paste:=xlPasteValues
   Next k
   Next j
Next i


'copy Names
For i = 1 To 4
   For j = 1 To cntplan
     For k = 1 To 66
   quarter_rows = s1.Range("E" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("B" & j).Copy
   s1.Range("E" & quarter_rows).PasteSpecial Paste:=xlPasteValues
   Next k
   Next j
Next i

End Sub

I have 43 plans with unique ID and these are for 0-65 age group and for 4 quarter. My final results are 11352 rows = 66 (age) * 43 plans * 4 quarters

1st column: year, all the same
2nd column: 1-4 quarter, should be 2838 of 1s, then 2838 of 2s ... 3nd column: all 1s 4th column: 43 IDs, each has 66 rows in each quarter 5th column: 43 names, same as IDs 6th column: 66 age (0-65), 172 chunks of 0-65 age rows

Could someone give me some advice on how to reduce the run time?

Thanks, SC

Upvotes: 0

Views: 450

Answers (1)

Tim Williams
Tim Williams

Reputation: 166196

For example:

'copy current year
For i = 1 To tot_year
s2.Range("Current_year").Copy
s1.Range("A" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy version
For i = 1 To tot_year
s2.Range("version").Copy
s1.Range("C" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

Would be faster as:

s1.Range("A2").Resize(tot_year, 1).Value = s2.Range("Current_year").Value
s1.Range("C2").Resize(tot_year, 1).Value = s2.Range("version").Value

Upvotes: 1

Related Questions