' 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