Code:
Dim objXL As Object Dim objWB As Object
Dim objWS As Object
Dim db As Database
Dim strSQL As String
Dim strSQL2 As String
Dim RS2 As Recordset
Dim lngCounter As Long
Dim RS As Recordset
Dim blnType2 As Boolean
Dim blnType3 As Boolean
Dim blnType4 As Boolean
Dim blnType5 As Boolean
Dim dtDate1 As Date
Dim dtDate2 As Date
Dim SetAColumn(1000) As String
Dim SetBColumn(1000) As String
Dim SetCColumn(1000) As String
Dim SetDColumn(1000) As String
Dim SetPColumn(1000) As String
Dim SetQColumn(1000) As String
Dim SetRColumn(1000) As String
Dim SetSColumn(1000) As String
Dim SetTColumn(1000) As String
Dim SetUColumn(1000) As String
Dim SetVColumn(1000) As String
Dim SetWColumn(1000) As String
Dim SetXColumn(1000) As String
Dim SetYColumn(1000) As String
Dim SetZColumn(1000) As String
Dim SetAAColumn(1000) As String
Dim SetABColumn(1000) As String
Dim SetACColumn(1000) As String
Dim Total As Double
Dim I As Long
Dim iNext As Long
lngCountType1 = 0: lngCountType2 = 0: lngCountType3 = 0: lngCountType4 = 0: lngCounttype5 = 0
For I = 0 To 1004
If I >= 4 Then
SetAColumn(I - 4) = Replace("A" + str(I), " ", ""): SetBColumn(I - 4) = Replace("B" + str(I), " ", ""): SetCColumn(I - 4) = Replace("C" + str(I), " ", ""): SetDColumn(I - 4) = Replace("D" + str(I), " ", "")
SetQColumn(I - 4) = Replace("Q" + str(I), " ", ""): SetPColumn(I - 4) = Replace("P" + str(I), " ", ""): SetRColumn(I - 4) = Replace("R" + str(I), " ", ""): SetSColumn(I - 4) = Replace("S" + str(I), " ", "")
SetTColumn(I - 4) = Replace("T" + str(I), " ", ""): SetUColumn(I - 4) = Replace("U" + str(I), " ", ""): SetWColumn(I - 4) = Replace("W" + str(I), " ", ""): SetXColumn(I - 4) = Replace("X" + str(I), " ", "")
SetYColumn(I - 4) = Replace("Y" + str(I), " ", ""): SetZColumn(I - 4) = Replace("Z" + str(I), " ", ""): SetAAColumn(I - 4) = Replace("AA" + str(I), " ", ""): SetABColumn(I - 4) = Replace("AB" + str(I), " ", "")
SetVColumn(I - 4) = Replace("V" + str(I), " ", ""): SetACColumn(I - 4) = Replace("AC" + str(I), " ", "")
End If
Next I
Set objXL = CreateObject("Excel.Application")
Set objWB = objXL.Workbooks.Open("\\srv-sbs2012\Company\Apps\Access Development Front End\PhilReportTemplate.xlsx")
Set objWS = objWB.Worksheets("InvoiceTo")
Set db = CurrentDb
' Or 'BC' Or 'MB' Or 'NS' Or 'On' Or 'SK' Or 'YT'
strSQL = "SELECT tblCompany.Type, tblCompany.Province, [CompanyName] & '(' & [address] & ')' AS Company, tblCompany.City, tblCompany.CompanyID " & _
"FROM tblCompany " & _
"WHERE (((tblCompany.Type)=1 Or (tblCompany.Type)=2 Or (tblCompany.Type)=3 Or (tblCompany.Type)=4 Or (tblCompany.Type)=5) AND ((tblCompany.Province)='" & ProvinceName & "') AND ((tblCompany.IsActive)=True)) " & _
"ORDER BY tblCompany.Province, tblCompany.Type;"
Set RS = CurrentDb.OpenRecordset(strSQL)
If RS.RecordCount > 0 Then
RS.MoveFirst
SysCmd acSysCmdInitMeter, "Busy Inserting New Lines........", RS.RecordCount
While RS.EOF = False
DoEvents
objWS.Activate
SysCmd acSysCmdUpdateMeter, lngCounter
objWS.Rows(lngCounter + 4).Insert Shift:=xlDown
ActiveCell.EntireRow.Insert
lngCounter = lngCounter + 1
RS.MoveNext
Wend
End If
SysCmd acSysCmdInitMeter, "Busy Inserting New Columns For Month Splitting........", RS.RecordCount
With cmbMonth
Select Case .Column(1, .ListIndex)
Case 1: ' January
For iNext = 0 To 0
Next iNext
objWS.Range("Q3").Value = "January"
Case 2: ' February
For iNext = 0 To 1
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
Case 3: ' March
For iNext = 0 To 2
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
Case 4: ' April
For iNext = 0 To 3
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
Case 5: ' May
For iNext = 0 To 4
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
Case 6: ' June
For iNext = 0 To 5
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
Case 7: ' July
For iNext = 0 To 6
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
Case 8: ' August
For iNext = 0 To 7
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("X3").Value = "August"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
Case 9: ' September
For iNext = 0 To 8
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("X3").Value = "August"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("Y3").Value = "September"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
Case 10: ' October
For iNext = 0 To 9
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("X3").Value = "August"
objWS.Range(SetYColumn(0)).EntireColumn.Insert
objWS.Range("Y3").Value = "September"
objWS.Range(SetZColumn(0)).EntireColumn.Insert
objWS.Range("Z3").Value = "October"
objWS.Range(SetAAColumn(0)).EntireColumn.Insert
Case 11: ' November
For iNext = 0 To 10
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("X3").Value = "August"
objWS.Range(SetYColumn(0)).EntireColumn.Insert
objWS.Range("Y3").Value = "September"
objWS.Range(SetZColumn(0)).EntireColumn.Insert
objWS.Range("Z3").Value = "October"
objWS.Range(SetAAColumn(0)).EntireColumn.Insert
objWS.Range("AA3").Value = "November"
objWS.Range(SetABColumn(0)).EntireColumn.Insert
Case 12: ' December
For iNext = 0 To 11
Next iNext
objWS.Range("Q3").Value = "January"
objWS.Range("R3").Value = "February"
objWS.Range(SetSColumn(0)).EntireColumn.Insert
objWS.Range("S3").Value = "March"
objWS.Range(SetTColumn(0)).EntireColumn.Insert
objWS.Range("T3").Value = "April"
objWS.Range(SetUColumn(0)).EntireColumn.Insert
objWS.Range("U3").Value = "May"
objWS.Range(SetVColumn(0)).EntireColumn.Insert
objWS.Range("V3").Value = "June"
objWS.Range(SetWColumn(0)).EntireColumn.Insert
objWS.Range("W3").Value = "July"
objWS.Range(SetXColumn(0)).EntireColumn.Insert
objWS.Range("X3").Value = "August"
objWS.Range(SetYColumn(0)).EntireColumn.Insert
objWS.Range("Y3").Value = "September"
objWS.Range(SetZColumn(0)).EntireColumn.Insert
objWS.Range("Z3").Value = "October"
objWS.Range(SetAAColumn(0)).EntireColumn.Insert
objWS.Range("AA3").Value = "November"
objWS.Range(SetABColumn(0)).EntireColumn.Insert
objWS.Range("AB3").Value = "December"
objWS.Range(SetACColumn(0)).EntireColumn.Insert
End Select
End With
objXL.Visible = False
objWB.Close SaveChanges:=True
' Now I am going to re-open the file and store the data in it
Set objXL = CreateObject("Excel.Application")
Set objWB = objXL.Workbooks.Open("\\srv-sbs2012\Company\Apps\Access Development Front End\PhilReportTemplate.xlsx")
Set objWS = objWB.Worksheets("InvoiceTo")
Set db = CurrentDb
lngCounter = 0
If RS.RecordCount > 0 Then
RS.MoveFirst
SysCmd acSysCmdInitMeter, "Busy Filling Data And Calculating Total Clock Count (Don't ask! Ok? -_-)........", RS.RecordCount
While RS.EOF = False
DoEvents
objWS.Activate
SysCmd acSysCmdUpdateMeter, lngCounter
With RS.Fields(0)
If .Value = 1 Then lngCountType1 = lngCountType1 + 1
If .Value = 2 Then lngCountType2 = lngCountType2 + 1
If .Value = 3 Then lngCountType3 = lngCountType3 + 1
If .Value = 4 Then lngCountType4 = lngCountType4 + 1
If .Value = 5 Then lngCounttype5 = lngCounttype5 + 1
End With
objWS.Range(SetAColumn(lngCounter)).Value = RS.Fields(1).Value ' Province
objWS.Range(SetBColumn(lngCounter)).Value = RS.Fields(0).Value ' Type
objWS.Range(SetCColumn(lngCounter)).Value = RS.Fields(2).Value ' Company Name
objWS.Range(SetDColumn(lngCounter)).Value = RS.Fields(3).Value ' City
lngCounter = lngCounter + 1
RS.MoveNext
Wend
End If
objXL.Visible = False
objWB.Close SaveChanges:=True
blnType2 = False: blnType3 = False: blnType4 = False: blnType5 = False
' lngCounter = 0: I = 0
SysCmd acSysCmdInitMeter, "Done. Moving To Next Task...", 0
SysCmd acSysCmdUpdateMeter, 0
lngCounter = 0
' Now I am going to generate a maximum total of 2017
dtDate1 = Replace("1/1/" & Val(txtYear) - 1, " ", "")
dtDate2 = Replace("12/31/" & Val(txtYear) - 1, " ", "")
dblTotal = 0
Set objXL = CreateObject("Excel.Application")
Set objWB = objXL.Workbooks.Open("\\srv-sbs2012\Company\Apps\Access Development Front End\PhilReportTemplate.xlsx")
Set objWS = objWB.Worksheets("InvoiceTo")
Set db = CurrentDb
lngCounter = 0
objWS.Range("P3").Value = dtDate1 & " Total"
If RS.RecordCount > 0 Then
RS.MoveFirst
SysCmd acSysCmdInitMeter, "Busy Inserting Total Of Year " & Val(txtYear) - 1 & "........", RS.RecordCount
While RS.EOF = False
DoEvents
objWS.Activate
SysCmd acSysCmdUpdateMeter, lngCounter
strSQL2 = "SELECT LineTotal FROM qryInvoiceToCompanyLastYearTotal WHERE DateCreated BETWEEN #" & dtDate1 & "# AND #" & dtDate2 & "# AND CompanyID=" & RS.Fields(4).Value
Set RS2 = CurrentDb.OpenRecordset(strSQL2)
If RS2.RecordCount > 0 Then
While RS2.EOF = False
Total = Total + RS2.Fields(0).Value
RS2.MoveNext
Wend
Else
Total = 0
End If
objWS.Range(SetPColumn(lngCounter)).Value = Total
Total = 0
lngCounter = lngCounter + 1
RS.MoveNext
Wend
End If
objXL.Visible = False
objWB.Close SaveChanges:=True
Set objXL = CreateObject("Excel.Application")
Set objWB = objXL.Workbooks.Open("\\srv-sbs2012\Company\Apps\Access Development Front End\PhilReportTemplate.xlsx")
Set objWS = objWB.Worksheets("InvoiceTo")
Set db = CurrentDb
lngCounter = 0
Dim strSQLMonth As String
Dim RSMonth As Recordset
lngNext = 0: I = 0
If RS.RecordCount > 0 Then
RS.MoveFirst
SysCmd acSysCmdInitMeter, "Generating Monthly Split And Spitting Out Grand Total........", RS.RecordCount
While RS.EOF = False
DoEvents
objWS.Activate
SysCmd acSysCmdUpdateMeter, lngCounter
strSQLMonth = "SELECT LineTotal, DateCreated FROM qryInvoiceToCompanyLastYearTotal WHERE DateCreated Between #1/1/" & txtYear & "# AND #" & retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) & "/" & IIf(retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 2, 28, IIf(retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 1 Or _
retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 3 Or retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 5 Or retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 7 Or retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 8 Or _
retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 10 Or retMonthNum(cmbMonth.Column(0, cmbMonth.ListIndex)) = 12, 31, 30)) & "/" & txtYear & "# AND CompanyID=" & RS.Fields(4).Value
Set RSMonth = CurrentDb.OpenRecordset(strSQLMonth)
'Call MsgBox(strSQLMonth)
If RSMonth.RecordCount > 0 Then
RSMonth.MoveFirst
While RSMonth.EOF = False
LineTotal = LineTotal + RSMonth.Fields(0).Value
If Month(RSMonth.Fields(1).Value) = 1 Then
objWS.Range(SetQColumn(lngCounter)).Value = LineTotal: I = 1: End If
If Month(RSMonth.Fields(1).Value) = 2 Then
objWS.Range(SetRColumn(lngCounter)).Value = LineTotal: I = 2: End If
If Month(RSMonth.Fields(1).Value) = 3 Then
objWS.Range(SetSColumn(lngCounter)).Value = LineTotal: I = 3: End If
If Month(RSMonth.Fields(1).Value) = 4 Then
objWS.Range(SetTColumn(lngCounter)).Value = LineTotal: I = 4: End If
If Month(RSMonth.Fields(1).Value) = 5 Then
objWS.Range(SetUColumn(lngCounter)).Value = LineTotal: I = 5: End If
If Month(RSMonth.Fields(1).Value) = 6 Then
objWS.Range(SetVColumn(lngCounter)).Value = LineTotal: I = 6: End If
If Month(RSMonth.Fields(1).Value) = 7 Then
objWS.Range(SetWColumn(lngCounter)).Value = LineTotal: I = 7: End If
If Month(RSMonth.Fields(1).Value) = 8 Then
objWS.Range(SetXColumn(lngCounter)).Value = LineTotal: I = 8: End If
If Month(RSMonth.Fields(1).Value) = 9 Then
objWS.Range(SetYColumn(lngCounter)).Value = LineTotal: I = 9: End If
If Month(RSMonth.Fields(1).Value) = 10 Then
objWS.Range(SetZColumn(lngCounter)).Value = LineTotal: I = 10: End If
If Month(RSMonth.Fields(1).Value) = 11 Then
objWS.Range(SetAAColumn(lngCounter)).Value = LineTotal: I = 11: End If
If Month(RSMonth.Fields(1).Value) = 12 Then
objWS.Range(SetABColumn(lngCounter)).Value = LineTotal: I = 12: End If
RSMonth.MoveNext
Wend
Else
LineTotal = 0
End If
LineTotal = 0
lngCounter = lngCounter + 1
RS.MoveNext
Wend
End If
LineTotal = 0
objWS.Range("Q2").Value = Val(txtYear) ' Set a year stamp there
Select Case I
Case 1:
objWS.Range(SetRColumn("R3")).Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetRColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetQColumn(LineTotal) & ")"
Next LineTotal
Case 2:
objWS.Range("S3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetSColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetRColumn(LineTotal) & ")"
Next LineTotal
Case 3:
objWS.Range("T3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetTColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetSColumn(LineTotal) & ")"
Next LineTotal
Case 4:
objWS.Range("U3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetUColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetTColumn(LineTotal) & ")"
Next LineTotal
Case 5:
objWS.Range("V3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetVColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetUColumn(LineTotal) & ")"
Next LineTotal
Case 6:
objWS.Range("W3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetWColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetVColumn(LineTotal) & ")"
Next LineTotal
Case 7:
objWS.Range("X3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetXColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetWColumn(LineTotal) & ")"
Next LineTotal
Case 8:
objWS.Range("Y3").Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetYColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetXColumn(LineTotal) & ")"
Next LineTotal
Case 9:
objWS.Range(("Z3")).Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetZColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetYColumn(LineTotal) & ")"
Next LineTotal
Case 10:
objWS.Range(("AA3")).Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetAAColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetZColumn(LineTotal) & ")"
Next LineTotal
Case 11:
objWS.Range(("AB3")).Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetABColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetAAColumn(LineTotal) & ")"
Next LineTotal
Case 12:
objWS.Range(("AC3")).Value = "2018 Total"
For LineTotal = 0 To lngCounter
objWS.Range(SetACColumn(LineTotal)).Value = "=SUM(" & SetQColumn(LineTotal) & ":" & SetABColumn(LineTotal) & ")"
Next LineTotal
End Select
objWS.Range("A3").Value = "Prov": objWS.Range("B3").Value = "Type": objWS.Range("C3").Value = "Company": objWS.Range("D3").Value = "City"
objXL.Visible = False
objWB.Close SaveChanges:=True
SysCmd acSysCmdInitMeter, "Done.", 0
SysCmd acSysCmdUpdateMeter, 0
objXL.Quit
Above is my code!