Optimizing Slow VBA Code to Copy & Paste Formulas

[itskdii]

Hello - I am looking for any assistance someone can provide to help me optimize this slow VBA code. Processing 20,000 rows of data takes about 7 minutes.

Basically I have four columns of data generated from formulas - 1 sumifs, 1 countifs, and 2 vlookup. I calc the first row and then want to paste down to the last row of the sheet. I've tried to optimize my code as much as possible by implementing tips I found online. Any other suggestions would be appreciated. Please go easy on me - I'm a newbie.

Also - I'm using XP, Excel 2010
Thanks!

Sub retrieve_AccessData()


Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, intColIndex As Integer, DBFullName As String, TableName As String, TargetRange As Range


Dim sd As Date 'start date
Dim ed As Date 'end date



Set TargetRange = Sheets("BUS_Data").Cells(1, 1)


'input variables
sd = Sheets("Data_Selection").Range("c3").Value
ed = Sheets("Data_Selection").Range("c4").Value
DBFullName = "\\Rags004\AccessDB\Productivity\BUS_Productivity_Trakker.accdb"
TableName = "BUS_Raw"




'clear worksheet for data entry
Sheets("BUS_Data").Activate
[Cells].ClearContents
Range("A1").Select

'open the database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DBFullName & ";"
Set rs = New ADODB.Recordset
mysql = "SELECT work_date, wc, user_id, user_name, oper, qty_conf, dshp FROM BUS_Raw WHERE work_date Between #" & sd & "# And #" & ed & "#"
With rs
.Open mysql, cn, adOpenStatic

For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next
TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

'pull clock hrs from kronos data
Sheets("BUS_Data").Select
Range("H1").Value = "clk_hrs"
Range("H2").FormulaR1C1 = _
"=SUM(SUMIFS(Kronos_Data!C7,Kronos_Data!C1,BUS_Data!RC1,Kronos_Data!C2,BUS_Data!RC3,Kronos_Data!C6,{""Regular"",""Overtime"",""Doubletime""}))"


'remove duplicate clock hrs for the same date and user id
Range("I1").Value = "tot_clk_hrs"
Range("I2").FormulaR1C1 = _
"=IF(COUNTIFS(R2C1:RC1,RC[-8],R2C3:RC3,RC[-6])=1,RC[-1],0)"


'pull in dept ref based on the wc
Range("J1").Value = "dept"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC[-8],wc_xref!C[-9]:C[-6],4,FALSE)"


'pull in dept_home from kronos data based on user id
Range("K1").Value = "dept_home"
Range("K2").FormulaR1C1 = "=VLOOKUP(RC[-8],Kronos_Data!C[-9]:C[-7],3,FALSE)"

'copy formulas to the bottom of the sheet and replace with values
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
Range("H2:K2").Copy Destination:=Range("H3:K" & lastRow) 'copy / paste to last row **this is where it gets really slow**
Range("H2:K" & lastRow).Value = Range("H2:K" & lastRow).Value 'replace formulas with values
End With

Sheets("Data_Selection").Select
Range("A1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True




End Sub

 

[jimrward]

you seem part way there, try setting the calculation to manual, in the same place that you turn off alerts, and set it to automatic at the end

'Speeding Up VBA Code
    Application.ScreenUpdating = False 'Prevent screen flickering
    Application.Calculation = xlCalculationManual 'Preventing calculation

and at the end

'Remove All Speeding Up VBA Code
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

 

[itskdii]

you seem part way there, try setting the calculation to manual, in the same place that you turn off alerts, and set it to automatic at the end

'Speeding Up VBA Code
    Application.ScreenUpdating = False 'Prevent screen flickering
    Application.Calculation = xlCalculationManual 'Preventing calculation

and at the end

'Remove All Speeding Up VBA Code
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

Thanks for the reply! Actually after adding the code it looks like it prevented the copy / paste function from actually doing the calcs associated with the formulas. Basically in cells H3:K & lastrow - it copies the formulas from H2:K2 but since the doesnt do the calc it displays the value from H2:K2 as well.

Also - one point of clarification - the goal of this spreadsheet is to be able to calculate a years worth of data. What that amounts to is evaluate @ 240K lines of data from the Kronos_Data tab to calc and populate @ 180K lines of data on the BUS_Data tab. Is it ridiculous to think I could optimize code to do this in a few seconds?

 

[jimrward]

Try moving the calculation switch to automatic to after the end with

 

[itskdii]

Try moving the calculation switch to automatic to after the end with

After the "end with" has the same effect. I also tried doing it between the copy / paste and paste values. That made the copy / paste quick but when I flipped the calc back on that took about 7 min (same amount of time in my original code).

 

[jimrward]

my only other thoughts would be as follows, given that VLOOKUP is volatile and expensive on resources

Application.Calculation = xlCalculationManual 

'copy formulas to the bottom of the sheet and replace with values
Dim lastRow As Long
With ActiveSheet
    lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
    Range("H2:K2").Copy Destination:=Range("H3:K" & lastRow) 'copy / paste to last row **this is where it gets really slow**
    Range("H2:K" & lastRow).Value = Range("H2:K" & lastRow).Value 'replace formulas with values
End With

Application.Calculation = xlCalculationAutomatic

 

[itskdii]

thanks for your help!

 

[jimrward]

Did that work, what is the timing like now ??

 

[itskdii]

No - it was a little faster but it didnt do the formula calc before copying and pasting as values.

 

[jimrward]

Can you post your current code