Code: Select all
Sub StallworthReportB()
Dim db As DAO.Database
Set db = CurrentDb
Set objxl = CreateObject("excel.application")
objxl.Workbooks.Open FileName:=CurrentDBDir & "StallworthReportTemplate.xlsx"
objxl.Visible = True
objxl.Sheets("Totals").Select
objxl.Range("B5").Select
'open the query and write the results
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("qryDataForStallworthReport_CrosstabB", dbOpenForwardOnly)
While Not rst.EOF
objxl.ActiveCell.Value = rst![Org Name]
objxl.ActiveCell.offset(0, 1).Value = rst![0-18 Months]
objxl.ActiveCell.offset(0, 2).Value = rst![19-36 Months]
objxl.ActiveCell.offset(0, 3).Value = rst![> 36 Months]
objxl.ActiveCell.offset(1, 0).Select
rst.MoveNext
Wend
rst.Close
Set rst = Nothing
'Delete the extra rows
Dim x As Integer
x = 20
While objxl.ActiveCell.Value <> "Total"
Rows(objxl.ActiveCell.Row + x).Delete Shift:=xlUp 'This is the row that errors the second time
x = x - 1
Rows(objxl.ActiveCell.Row).Delete Shift:=xlUp
Wend
objxl.ActiveCell.offset(5, 0).Select
'Now do the Orgs individually
Set rst = db.OpenRecordset("SELECT DISTINCT [Org Name] FROM qryDataForStallworthReportB order by 1 DESC", dbOpenForwardOnly)
While Not rst.EOF
'Make a copy of the template sheet
objxl.Sheets("OrgTemplate").Select
objxl.Sheets("OrgTemplate").Copy after:=Sheets(2)
objxl.Sheets("OrgTemplate (2)").Name = Nz(rst![Org Name], "No Org Defined")
'Put the data in
objxl.Range("B2").Select
objxl.ActiveCell.Value = rst![Org Name]
objxl.Range("B5").Select
Dim rst2 As DAO.Recordset
Dim str2 As String
If IsNull(rst![Org Name]) Then
str2 = "SELECT * FROM qryDataForStallworthReport_Crosstab2B WHERE [Org Name] IS NULL"
Else
str2 = "SELECT * FROM qryDataForStallworthReport_Crosstab2B WHERE [Org Name] = '" & rst![Org Name] & "'"
End If
Set rst2 = db.OpenRecordset(str2, dbOpenForwardOnly)
While Not rst2.EOF
objxl.ActiveCell.Value = rst2![VP Name]
objxl.ActiveCell.offset(0, 1).Value = rst2![0-18 Months]
objxl.ActiveCell.offset(0, 2).Value = rst2![19-36 Months]
objxl.ActiveCell.offset(0, 3).Value = rst2![> 36 Months]
objxl.ActiveCell.offset(1, 0).Select
rst2.MoveNext
Wend
'Delete the extra rows
While objxl.ActiveCell.Value <> "Total"
Rows(objxl.ActiveCell.Row).Delete Shift:=xlUp
Wend
rst.MoveNext
Wend
objxl.Sheets("OrgTemplate").Select
objxl.ActiveSheet.Delete
Set db = Nothing
objxl.ActiveWorkbook.SaveAs FileName:=CurrentDBDir & "\Reports\" & Format(Now, "YYYYMMDD-hhmm") & " - StallworthReport-ContingentOnly.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
objxl.ActiveWorkbook.Close SaveChanges:=False
'Close the Spreadsheet
objxl.Workbooks.Close
objxl.Quit
Set objxl = Nothing
'MsgBox "Done!"
End Sub
Code: Select all
Rows(objxl.ActiveCell.Row + x).Delete Shift:=xlUp 'This is the row that errors the second time
Any idea what might be causing that error and how to fix it?
The reason I run it twice is because I change the source query for a second set of reports.