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