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