ossuary
06-03-2013, 06:24 AM
Hello all,
I just found this forum, and I'm looking forward to learning lots of new tricks. :)
I have an automated reporting tool that replaced our old manual process. Formerly, once a month we would create several hundred excel reports (one file per cost center), and mail them all out to the people who need them.
My new system creates a single workbook for each owner. So someone who owns 10 cost centers gets a single email and single attachment instead of 10 of each, and the accountants who have to review 100 of the accounts have finally stopped cowering under their desks and crying every month. ;)
The problem I'm having is that my automated system is still pretty slow, because of the number of workbooks and worksheets it's creating. Each file it creates has a summary page, showing just the totals for each account (so they can quickly spot large discrepancies), and then a separate tab for each account showing all the detailed line items, subtotaled. The data for each worksheet is queried from an access database with all of the raw data for the month, and exported to each tab of the workbook.
The original process took about 6 hours to run (and resulted in all those horrifying emails). My version runs in about an hour, taking between 5 and 30 seconds per file depending on how many accounts are in it. I know there must be ways to make this process run faster, but I'm not a super advanced user and don't know where to look for time gains. A colleague showed me a program that uses class modules to dump data from a master file into single-worksheet attachment files at lightning speed, but I can't make heads or tails of how the code works, or figure out how to modify it to make multiple worksheets per file instead of a single sheet.
Can you guys give me some pointers on things I could do to speed this process up and be less resource intensive? I was thinking it might be faster if I used a multidimensional array holding all of the month's data instead of querying the database for each individual cost center, but I couldn't figure out how to then extract the individual cost centers out of the array. Any tips are greatly appreciated!
The program is written in Excel 2007, though some people in the office still use 2003, so it's written to save the attachments in 2003 format if the person running it is in the older version. Here's the bulk of the code I'm using to pull the data from the database and create the reports from the template (I've removed the code that isn't relevant to creating / populating the files):
' Create Reports button
Range("rStart").Select
' Set system and report variables
Dim wsf As WorksheetFunction
Dim sL As Worksheet, sS As Worksheet, sT As Worksheet, ns As Worksheet, sht As Worksheet
Dim cb As Workbook, nb As Workbook
Set wsf = WorksheetFunction
Set sL = Sheets("Lookups")
Set cb = Workbooks(ThisWorkbook.Name)
' Get report details
sr1 = 14 'summary start row
sc1 = 2 'summary start column
sc2 = 9 'summary end column
sfc = 4 'summary filter columns
dr1 = 6 'detail start row
dc1 = 1 'detail start column
' Create a directory for the reports
'' irrelevant code removed
' Open the database connection
'' irrelevant code removed
' Open the Cost Center Template, and identify its tabs
nbFile = ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, "Exporter", "template")
Set nb = Workbooks.Open(Filename:=nbFile, ReadOnly:=1)
Set sS = nb.Sheets("Summary")
Set sT = nb.Sheets("template")
cb.Activate
Application.ScreenUpdating = False
Application.Wait (Now + TimeValue("00:00:00"))
' Loop for each user group
myFC = 0
For a = 1 To 3
If a = 1 Then t1 = "Owner"
If a = 2 Then t1 = "Reviewer"
If a = 3 Then t1 = "Backup"
' Delete any old data
x = sL.Cells(Rows.Count, 3).End(xlUp).Row
If x > 1 Then sL.Range(sL.Cells(2, 3), sL.Cells(x, 3)).Delete shift:=xlUp
' Get list of users with active Cost Centers
sSQL = "SELECT [User ID] FROM [qryUsers] WHERE [Type] = '" & t1 & "';"
' Open the recordset
Set rst = New ADODB.Recordset
rst.Open sSQL, cnn, Options:=adCmdText
' Send list of users to Excel
sL.Cells(2, 3).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
r1 = sL.Cells(Rows.Count, 3).End(xlUp).Row
' Loop for each user
For b = 2 To r1
' Delete any old data, clean up template formatting
x = sL.Cells(Rows.Count, 5).End(xlUp).Row
If x > 1 Then sL.Range(sL.Cells(2, 5), sL.Cells(x, 8)).Delete shift:=xlUp
sr2 = sS.Cells(Rows.Count, sc1).End(xlUp).Row
If sr2 > sr1 Then sS.Range(sS.Rows(sr1 + 1), sS.Rows(sr2)).EntireRow.Delete shift:=xlUp
sS.Rows(sr1).ClearContents
If sS.AutoFilterMode Then sS.AutoFilterMode = False
sT.Visible = xlSheetVisible
Application.DisplayAlerts = False
For y = nb.Sheets.Count To 1 Step -1
If y > 2 Then nb.Sheets(y).Delete
Next y
Application.DisplayAlerts = True
' Get list of Cost Centers for the current user
u1 = sL.Cells(b, 3).Value
sSQL = "SELECT [Region], [Cost Center], [Owner Name], [Reviewer Name] " & _
"FROM [Cost_Centers] WHERE " & _
"[Region] IN('" & myRegs & "') AND " & _
"[" & t1 & " ID] = '" & u1 & "' " & _
"ORDER BY [Region], [Cost Center];"
' Open the recordset
Set rst = New ADODB.Recordset
rst.Open sSQL, cnn, Options:=adCmdText
' Send list of cost centers to Excel
sL.Cells(2, 5).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
r2 = sL.Cells(Rows.Count, 5).End(xlUp).Row
' Prepare the summary query for this user
'' irrelevant code removed
' Create the recordset and send to Excel
Set rst = cmd.Execute
If rst.EOF = True Then GoTo SkipThisUser
sS.Cells(sr1, sc1).CopyFromRecordset rst
' Close the recordset
rst.Close
Application.Wait (Now + TimeValue("00:00:00"))
sr2 = sS.Cells(Rows.Count, sc1).End(xlUp).Row
' Add autofilters to summary tab
sS.Range(sS.Cells(sr1 - 1, sc1), sS.Cells(sr2, sc1 + sfc)).AutoFilter
' Label the summary tab
sS.Range("B4").Value = "data for F" & Right(sL.Range("rFis1").Value, 2) & _
" P" & Format(sL.Range("rPer2").Value, "00") & " (" & sL.Range("rDate1").Value & _
" - " & sL.Range("rDate2").Value & ")"
' Loop for each cost center
For c = 2 To r2
' Prepare the detail query for this cost center
'' irrelevant code removed
' Create the recordset
Set rst = cmd.Execute
If rst.EOF = True Then GoTo SkipThisCC
' Create a new tab for this cost center
myC = nb.Sheets.Count
Application.Wait (Now + TimeValue("00:00:00"))
sT.Copy After:=nb.Sheets(myC)
Application.Wait (Now + TimeValue("00:00:00"))
Set ns = nb.Sheets(myC + 1)
ns.Name = sL.Cells(c, 5).Value & " " & sL.Cells(c, 6).Value
' Send data to Excel
ns.Cells(dr1, dc1).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
dr2 = ns.Cells(Rows.Count, dc1).End(xlUp).Row
' Add subtotals to this tab
On Error Resume Next
ns.Range(ns.Rows(dr1), ns.Rows(dr2)).EntireRow.Font.Bold = False
ns.Range(ns.Columns(dc1), ns.Columns(dc2)).RemoveSubtotal
ns.Range(ns.Cells(dr1 - 1, dc1), ns.Cells(dr2, dc2)).Subtotal GroupBy:=8, _
Function:=xlSum, TotalList:=Array(10, 11), Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
dr2 = ns.Cells(Rows.Count, 8).End(xlUp).Row
For d = dr1 To dr2
If Right(ns.Cells(d, 8).Value, 5) = "Total" Then
ns.Rows(d).EntireRow.Font.Bold = True
ns.Cells(d, dc2).Value = ns.Cells(d, dc2 - 1).Value - ns.Cells(d, dc2 - 2).Value
End If
Next d
On Error GoTo 0
' Label this tab
ns.Range("E1").Value = "F" & Right(sL.Range("rFis1").Value, 2) & _
" P" & Format(sL.Range("rPer2").Value, "00") & " Cost Center Report: " & _
sL.Cells(c, 6).Value
ns.Cells(1, 11).Value = sL.Cells(c, 7).Value
ns.Cells(2, 11).Value = sL.Cells(c, 8).Value
SkipThisCC:
If rst.State = 1 Then rst.Close
Next c
' Prepare to save the report
Application.Wait (Now + TimeValue("00:00:00"))
myRep = myFold & " (" & u1 & ").xlsm"
If a = 2 Then myRep = Replace(myRep, " (", " R (")
If a = 3 Then myRep = Replace(myRep, " (", " A (")
myVal = myPath & "\" & myRep
myFC = myFC + 1
sS.Activate
sT.Visible = xlSheetHidden
Application.Wait (Now + TimeValue("00:00:01"))
' Make sure the report doesn't already exist
If Dir(myVal, vbDirectory) <> Null Then
Kill myVal
End If
If Dir(Replace(myVal, "xlsm", "xls"), vbDirectory) <> Null Then
Kill Replace(myVal, "xlsm", "xls")
End If
' Save the report
If Application.Version >= 12 Then
nb.SaveAs Filename:=myVal, FileFormat:=52
Else
myVal = Replace(myVal, "xlsm", "xls")
myRep = Replace(myRep, "xlsm", "xls")
nb.SaveAs Filename:=myVal, FileFormat:=56
End If
Application.Wait (Now + TimeValue("00:00:01"))
cb.Activate
SkipThisUser:
If rst.State = 1 Then rst.Close
Next b
Next a
' Clean up and close
Application.ScreenUpdating = True
nb.Close SaveChanges:=0
cnn.Close
I just found this forum, and I'm looking forward to learning lots of new tricks. :)
I have an automated reporting tool that replaced our old manual process. Formerly, once a month we would create several hundred excel reports (one file per cost center), and mail them all out to the people who need them.
My new system creates a single workbook for each owner. So someone who owns 10 cost centers gets a single email and single attachment instead of 10 of each, and the accountants who have to review 100 of the accounts have finally stopped cowering under their desks and crying every month. ;)
The problem I'm having is that my automated system is still pretty slow, because of the number of workbooks and worksheets it's creating. Each file it creates has a summary page, showing just the totals for each account (so they can quickly spot large discrepancies), and then a separate tab for each account showing all the detailed line items, subtotaled. The data for each worksheet is queried from an access database with all of the raw data for the month, and exported to each tab of the workbook.
The original process took about 6 hours to run (and resulted in all those horrifying emails). My version runs in about an hour, taking between 5 and 30 seconds per file depending on how many accounts are in it. I know there must be ways to make this process run faster, but I'm not a super advanced user and don't know where to look for time gains. A colleague showed me a program that uses class modules to dump data from a master file into single-worksheet attachment files at lightning speed, but I can't make heads or tails of how the code works, or figure out how to modify it to make multiple worksheets per file instead of a single sheet.
Can you guys give me some pointers on things I could do to speed this process up and be less resource intensive? I was thinking it might be faster if I used a multidimensional array holding all of the month's data instead of querying the database for each individual cost center, but I couldn't figure out how to then extract the individual cost centers out of the array. Any tips are greatly appreciated!
The program is written in Excel 2007, though some people in the office still use 2003, so it's written to save the attachments in 2003 format if the person running it is in the older version. Here's the bulk of the code I'm using to pull the data from the database and create the reports from the template (I've removed the code that isn't relevant to creating / populating the files):
' Create Reports button
Range("rStart").Select
' Set system and report variables
Dim wsf As WorksheetFunction
Dim sL As Worksheet, sS As Worksheet, sT As Worksheet, ns As Worksheet, sht As Worksheet
Dim cb As Workbook, nb As Workbook
Set wsf = WorksheetFunction
Set sL = Sheets("Lookups")
Set cb = Workbooks(ThisWorkbook.Name)
' Get report details
sr1 = 14 'summary start row
sc1 = 2 'summary start column
sc2 = 9 'summary end column
sfc = 4 'summary filter columns
dr1 = 6 'detail start row
dc1 = 1 'detail start column
' Create a directory for the reports
'' irrelevant code removed
' Open the database connection
'' irrelevant code removed
' Open the Cost Center Template, and identify its tabs
nbFile = ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, "Exporter", "template")
Set nb = Workbooks.Open(Filename:=nbFile, ReadOnly:=1)
Set sS = nb.Sheets("Summary")
Set sT = nb.Sheets("template")
cb.Activate
Application.ScreenUpdating = False
Application.Wait (Now + TimeValue("00:00:00"))
' Loop for each user group
myFC = 0
For a = 1 To 3
If a = 1 Then t1 = "Owner"
If a = 2 Then t1 = "Reviewer"
If a = 3 Then t1 = "Backup"
' Delete any old data
x = sL.Cells(Rows.Count, 3).End(xlUp).Row
If x > 1 Then sL.Range(sL.Cells(2, 3), sL.Cells(x, 3)).Delete shift:=xlUp
' Get list of users with active Cost Centers
sSQL = "SELECT [User ID] FROM [qryUsers] WHERE [Type] = '" & t1 & "';"
' Open the recordset
Set rst = New ADODB.Recordset
rst.Open sSQL, cnn, Options:=adCmdText
' Send list of users to Excel
sL.Cells(2, 3).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
r1 = sL.Cells(Rows.Count, 3).End(xlUp).Row
' Loop for each user
For b = 2 To r1
' Delete any old data, clean up template formatting
x = sL.Cells(Rows.Count, 5).End(xlUp).Row
If x > 1 Then sL.Range(sL.Cells(2, 5), sL.Cells(x, 8)).Delete shift:=xlUp
sr2 = sS.Cells(Rows.Count, sc1).End(xlUp).Row
If sr2 > sr1 Then sS.Range(sS.Rows(sr1 + 1), sS.Rows(sr2)).EntireRow.Delete shift:=xlUp
sS.Rows(sr1).ClearContents
If sS.AutoFilterMode Then sS.AutoFilterMode = False
sT.Visible = xlSheetVisible
Application.DisplayAlerts = False
For y = nb.Sheets.Count To 1 Step -1
If y > 2 Then nb.Sheets(y).Delete
Next y
Application.DisplayAlerts = True
' Get list of Cost Centers for the current user
u1 = sL.Cells(b, 3).Value
sSQL = "SELECT [Region], [Cost Center], [Owner Name], [Reviewer Name] " & _
"FROM [Cost_Centers] WHERE " & _
"[Region] IN('" & myRegs & "') AND " & _
"[" & t1 & " ID] = '" & u1 & "' " & _
"ORDER BY [Region], [Cost Center];"
' Open the recordset
Set rst = New ADODB.Recordset
rst.Open sSQL, cnn, Options:=adCmdText
' Send list of cost centers to Excel
sL.Cells(2, 5).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
r2 = sL.Cells(Rows.Count, 5).End(xlUp).Row
' Prepare the summary query for this user
'' irrelevant code removed
' Create the recordset and send to Excel
Set rst = cmd.Execute
If rst.EOF = True Then GoTo SkipThisUser
sS.Cells(sr1, sc1).CopyFromRecordset rst
' Close the recordset
rst.Close
Application.Wait (Now + TimeValue("00:00:00"))
sr2 = sS.Cells(Rows.Count, sc1).End(xlUp).Row
' Add autofilters to summary tab
sS.Range(sS.Cells(sr1 - 1, sc1), sS.Cells(sr2, sc1 + sfc)).AutoFilter
' Label the summary tab
sS.Range("B4").Value = "data for F" & Right(sL.Range("rFis1").Value, 2) & _
" P" & Format(sL.Range("rPer2").Value, "00") & " (" & sL.Range("rDate1").Value & _
" - " & sL.Range("rDate2").Value & ")"
' Loop for each cost center
For c = 2 To r2
' Prepare the detail query for this cost center
'' irrelevant code removed
' Create the recordset
Set rst = cmd.Execute
If rst.EOF = True Then GoTo SkipThisCC
' Create a new tab for this cost center
myC = nb.Sheets.Count
Application.Wait (Now + TimeValue("00:00:00"))
sT.Copy After:=nb.Sheets(myC)
Application.Wait (Now + TimeValue("00:00:00"))
Set ns = nb.Sheets(myC + 1)
ns.Name = sL.Cells(c, 5).Value & " " & sL.Cells(c, 6).Value
' Send data to Excel
ns.Cells(dr1, dc1).CopyFromRecordset rst
Application.Wait (Now + TimeValue("00:00:00"))
' Close the recordset
rst.Close
dr2 = ns.Cells(Rows.Count, dc1).End(xlUp).Row
' Add subtotals to this tab
On Error Resume Next
ns.Range(ns.Rows(dr1), ns.Rows(dr2)).EntireRow.Font.Bold = False
ns.Range(ns.Columns(dc1), ns.Columns(dc2)).RemoveSubtotal
ns.Range(ns.Cells(dr1 - 1, dc1), ns.Cells(dr2, dc2)).Subtotal GroupBy:=8, _
Function:=xlSum, TotalList:=Array(10, 11), Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
dr2 = ns.Cells(Rows.Count, 8).End(xlUp).Row
For d = dr1 To dr2
If Right(ns.Cells(d, 8).Value, 5) = "Total" Then
ns.Rows(d).EntireRow.Font.Bold = True
ns.Cells(d, dc2).Value = ns.Cells(d, dc2 - 1).Value - ns.Cells(d, dc2 - 2).Value
End If
Next d
On Error GoTo 0
' Label this tab
ns.Range("E1").Value = "F" & Right(sL.Range("rFis1").Value, 2) & _
" P" & Format(sL.Range("rPer2").Value, "00") & " Cost Center Report: " & _
sL.Cells(c, 6).Value
ns.Cells(1, 11).Value = sL.Cells(c, 7).Value
ns.Cells(2, 11).Value = sL.Cells(c, 8).Value
SkipThisCC:
If rst.State = 1 Then rst.Close
Next c
' Prepare to save the report
Application.Wait (Now + TimeValue("00:00:00"))
myRep = myFold & " (" & u1 & ").xlsm"
If a = 2 Then myRep = Replace(myRep, " (", " R (")
If a = 3 Then myRep = Replace(myRep, " (", " A (")
myVal = myPath & "\" & myRep
myFC = myFC + 1
sS.Activate
sT.Visible = xlSheetHidden
Application.Wait (Now + TimeValue("00:00:01"))
' Make sure the report doesn't already exist
If Dir(myVal, vbDirectory) <> Null Then
Kill myVal
End If
If Dir(Replace(myVal, "xlsm", "xls"), vbDirectory) <> Null Then
Kill Replace(myVal, "xlsm", "xls")
End If
' Save the report
If Application.Version >= 12 Then
nb.SaveAs Filename:=myVal, FileFormat:=52
Else
myVal = Replace(myVal, "xlsm", "xls")
myRep = Replace(myRep, "xlsm", "xls")
nb.SaveAs Filename:=myVal, FileFormat:=56
End If
Application.Wait (Now + TimeValue("00:00:01"))
cb.Activate
SkipThisUser:
If rst.State = 1 Then rst.Close
Next b
Next a
' Clean up and close
Application.ScreenUpdating = True
nb.Close SaveChanges:=0
cnn.Close