LinkBack URL
About LinkBacksI have the following code that runs from an Access Database and generates a
spreadsheet based on a query in the DB. The first time it runs, it works
fine. the second time I get the above mentioned error.
I was originally getting a different error about range of object global so I
changed all my range statements to .range now I get this new one. If I close
the database between runs every thing works fine. This leads me to believe
that I'm holding something in memory that causes the problem but I can't
figure it out. I posted this message on the Access forum and got some helpful
ideas that just didn't quite solve the problem.
Any help you Excel Guru's can offer would be greatly appreciated.
Thanks,
mpj
Code follows
Public Sub GenReports()
' Dimension the variables used in this Procedure
Dim xLApp As Excel.Application ' Tells Access about the Excel Application
Dim wb As Excel.Workbook ' Tell Access about an Excel workbook
Dim db As Database ' Names the database
Dim rs As DAO.Recordset ' Names a recordset
Dim i As Integer ' Creates an integer to be used as an index
Dim iRowCount As Integer ' Creates an integer to be used to keep track of
the current row
Dim iBorder As Integer
Dim iFieldNum As Integer ' Keeps track of the current field number in the
recordset.
Dim iRecordCount As Integer ' Holds the number of records returned for use
once the recordset is closed.
Dim s As String
Dim sSQL As String ' Creates the SQL used to select the data from a table or
query
Dim sDate As String ' Used to append a date to the file name when saving it
Dim sPath As String ' Determines the path for saving the file
Dim sFile As String ' Determines the name of the file when saving it
Dim sSysMsg As String ' Holds a message to be displayed in the status bar
Dim vSysCmd As Variant
Dim NewRange As String ' A string that holds a range based on some if
statement or select case.
Dim FillRange As String ' Creates a range for the purpose of using an autofill
Dim ClearRange As String ' Creates a range for the purpose of clearing cell
content
Dim FormRange As String ' Creates a range to use for formatting.
Dim ColRange As String ' same as above
Dim EndRange As String
Dim GrandRange As String
Dim LeftRange As String
Dim GrandCalc As String
Dim NewCol As String ' Same as above
Dim NewColTop As String ' same as above
Dim NextDown As String ' same as above
Dim CalcRange As String ' same as above
' Set the values for the file name, path and date.
sDate = Format(BegYrPlus(), "mm-dd-yyyy") & " - " & Format(EndYrPlus(),
"mm-dd-yyyy")
sPath = "\\NTFS2\AFLACGlobal\PMO\EPO Reporting\Monthly Reporting\Current
Reports\"
sFile = "Release Team Actuals"
' Display a message on the status bar.
sSysMsg = "Creating Reports"
' Open the Database in memory.
Set db = CurrentDb
' Define the SQL Statement to be used to create your recordset
sSQL = "SELECT * " _
& "FROM qry7_09_BCSums;" ' *** Change this to the appropriate query or
table name.
' Set the recordset as the results of your sql statement.
Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)
' Set up the Excel Objects
Set xLApp = New Excel.Application
Set wb = xLApp.Workbooks.Add()
' Begin the process of creating and filling the Excel sheet.
With rs
.MoveLast 'force error 3021 if no records
.MoveFirst
iRecordCount = .RecordCount
vSysCmd = SysCmd(acSysCmdInitMeter, sSysMsg, iRecordCount)
End With
xLApp.Visible = True
With wb.Worksheets(1)
.Name = "Release Team Actuals" ' Change the name of the active Excel
Sheet
'.Cells(1, 1).Value = "Excel Sheet Test" ' Place a heading in a
spcific cell if needed.
i = 1 ' Set the index. This should be adjusted if you put values in
spcific cells above.
' Set the field names based on the index and the number of fields in
your recordset.
For iFieldNum = 1 To rs.Fields.Count
.Cells(i, iFieldNum).Value = rs.Fields(iFieldNum - 1).Name
.Cells(i, iFieldNum).Borders.LineStyle = xlContinuous
.Cells(i, iFieldNum).Font.Name = "Arial Narrow"
.Cells(1, iFieldNum).Font.Bold = True
.Cells(i, iFieldNum).Interior.ColorIndex = 36
.Cells(i, iFieldNum).HorizontalAlignment = xlCenter
.Cells(i, iFieldNum).VerticalAlignment = xlCenter
Next
i = i + 1
Do Until rs.EOF
' Fill in the values on the worksheet.
For iFieldNum = 1 To rs.Fields.Count
.Cells(i, iFieldNum).Value = Nz(rs.Fields(iFieldNum - 1), "")
.Cells(i, iFieldNum).Borders.LineStyle = xlContinuous
.Cells(i, iFieldNum).Font.Name = "Arial Narrow"
.Cells(i, iFieldNum).HorizontalAlignment = xlCenter
.Cells(i, iFieldNum).VerticalAlignment = xlCenter
Next
vSysCmd = SysCmd(acSysCmdUpdateMeter, i)
i = i + 1
rs.MoveNext
Loop
iRowCount = i - 1
' Since this particular sheet contains variable headings
' we need to determine the correct value for the first one
' and then autofill the remainder
.Cells(1, 2).Value = Format(BegYrPlus(), "mmm-yyyy")
'*********************************************
'This is where it fails
.Range("B1").Select
Selection.AutoFill Destination:=.Range("B1:Y1"), Type:=xlFillDefault
.Range("B1:Y1").Select
'**********************************************
' Now since we know that there will always be one complete year
' followed by YTD for the current year.
' we insert a column for the first year's totals.
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
' Now go to the first cell of the new column and Insert the header
.Range("N1").Select
ActiveCell.FormulaR1C1 = Year(BegYrPlus) & " Totals"
' Now go to the next cell down and insert the total calculation.
.Range("N2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
' Now Set up the range for the autofill of the calculation
' then do the autofill and bold the column.
'.Range("N2").Select
FillRange = "N2:N" & iRecordCount + 1
Selection.AutoFill Destination:=Range(FillRange), Type:=xlFillDefault
FormRange = "N1:N" & iRecordCount + 1
.Range(FormRange).Select
Selection.Font.Bold = True
.Range(FormRange).Interior.ColorIndex = 36
'Selection.EntireColumn.AutoFit
' Now since the remainder of the sheet is variable, we need to
determine the
' current reporting month and set variables accordingly.
Select Case Month(EndYrPlus)
Case 1
ClearRange = "P1:Z" & iRecordCount + 1
ColRange = "O1:O" & iRecordCount + 1
NewCol = "P1:P" & iRecordCount + 1
NewColTop = "P1:P1"
NextDown = "P2:P2"
Case 2
ClearRange = "Q1:Z" & iRecordCount + 1
ColRange = "P1:P" & iRecordCount + 1
NewCol = "Q1:Q" & iRecordCount + 1
NewColTop = "Q1:Q1"
NextDown = "Q2:Q2"
Case 3
ClearRange = "R1:Z" & iRecordCount + 1
ColRange = "Q1:Q" & iRecordCount + 1
NewCol = "R1:R" & iRecordCount + 1
NewColTop = "R1:R1"
NextDown = "R2:R2"
Case 4
ClearRange = "S1:Z" & iRecordCount + 1
ColRange = "R1:R" & iRecordCount + 1
NewCol = "S1:S" & iRecordCount + 1
NewColTop = "S1:S1"
NextDown = "S2:S2"
Case 5
ClearRange = "T1:Z" & iRecordCount + 1
ColRange = "S1:S" & iRecordCount + 1
NewCol = "T1:T" & iRecordCount + 1
NewColTop = "T1:T1"
NextDown = "T2:T2"
Case 6
ClearRange = "U1:Z" & iRecordCount + 1
ColRange = "T1:T" & iRecordCount + 1
NewCol = "U1:U" & iRecordCount + 1
NewColTop = "U1:U1"
NextDown = "U2:U2"
Case 7
ClearRange = "V1:Z" & iRecordCount + 1
ColRange = "U1:U" & iRecordCount + 1
NewCol = "V1:V" & iRecordCount + 1
NewColTop = "V1:V1"
NextDown = "V2:V2"
Case 8
ClearRange = "W1:Z" & iRecordCount + 1
ColRange = "U1:U" & iRecordCount + 1
NewCol = "W1:W" & iRecordCount + 1
NewColTop = "W1:W1"
NextDown = "W2:W2"
Case 9
ClearRange = "X1:Z" & iRecordCount + 1
ColRange = "W1:W" & iRecordCount + 1
NewCol = "X1:X" & iRecordCount + 1
NewColTop = "X1:X1"
NextDown = "X2:X2"
Case 10
ClearRange = "Y1:Z" & iRecordCount + 1
ColRange = "X1:X" & iRecordCount + 1
NewCol = "Y1:Y" & iRecordCount + 1
NewColTop = "Y1:Y1"
NextDown = "Y2:Y2"
Case 11
ClearRange = "Z1:Z" & iRecordCount + 1
ColRange = "Y1:Y" & iRecordCount + 1
NewCol = "Z1:Z" & iRecordCount + 1
NewColTop = "Z1:Z1"
NextDown = "Z2:Z2"
Case 12
ColRange = "Z1:Z" & iRecordCount + 1
NewCol = "AA1:AA" & iRecordCount + 1
NewColTop = "AA1:AA1"
NextDown = "AA2:AA2"
End Select
' Unless it's the end of the year, in which case there are no
formatted cells
' that need to be cleared, clear the empty cells of all formatting.
If Left(ColRange, 1) = "Z" Then
GoTo CopyRange:
Else
.Range(ClearRange).Select
Selection.Clear
End If
CopyRange:
' This piece copies the formatting from the left into a new column
that
' will be used to hold the YTD Subtotals.
.Range(ColRange).Select
Selection.Copy
.Range(NewCol).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Range(NewColTop).Select
Selection.Value = Year(Date) & " Totals"
.Range(NextDown).Select
xLApp.CutCopyMode = False
'This piece inserts the YTD subtotals, does the autofil and some
formatting
' in the appropriate column based on reporting month.
Select Case Month(EndYrPlus())
Case 1
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]:RC[-1])"
NewCol = "P2:P" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:P" & iRecordCount + 1
NewRange = "A1:P" & iRecordCount + 1
EndRange = "P" & iRecordCount + 1
Case 2
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
NewCol = "Q2:Q" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:Q" & iRecordCount + 1
NewRange = "A1:Q" & iRecordCount + 1
EndRange = "Q" & iRecordCount + 1
Case 3
ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
NewCol = "R2:R" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:R" & iRecordCount + 1
NewRange = "A1:R" & iRecordCount + 1
EndRange = "R" & iRecordCount + 1
Case 4
ActiveCell.FormulaR1C1 = "=SUM(RC[-4]:RC[-1])"
NewCol = "S2:S" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:S" & iRecordCount + 1
NewRange = "A1:S" & iRecordCount + 1
EndRange = "S" & iRecordCount + 1
Case 5
ActiveCell.FormulaR1C1 = "=SUM(RC[-6]:RC[-1])"
NewCol = "T2:T" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:T" & iRecordCount + 1
NewRange = "A1:T" & iRecordCount + 1
EndRange = "T" & iRecordCount + 1
Case 6
ActiveCell.FormulaR1C1 = "=SUM(RC[-6]:RC[-1])"
NewCol = "U2:U" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:U" & iRecordCount + 1
NewRange = "A1:U" & iRecordCount + 1
EndRange = "A1:U" & iRecordCount + 2
GrandRange = "B" & iRecordCount + 2 & ":U" & iRecordCount + 2
Case 7
ActiveCell.FormulaR1C1 = "=SUM(RC[-7]:RC[-1])"
NewCol = "V2:V" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:V" & iRecordCount + 1
NewRange = "A1:V" & iRecordCount + 1
EndRange = "V" & iRecordCount + 1
Case 8
ActiveCell.FormulaR1C1 = "=SUM(RC[-8]:RC[-1])"
NewCol = "W2:W" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:W" & iRecordCount + 1
NewRange = "A1:W" & iRecordCount + 1
EndRange = "W" & iRecordCount + 1
Case 9
ActiveCell.FormulaR1C1 = "=SUM(RC[-9]:RC[-1])"
NewCol = "X2:X" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:X" & iRecordCount + 1
NewRange = "A1:X" & iRecordCount + 1
EndRange = "X" & iRecordCount + 1
Case 10
ActiveCell.FormulaR1C1 = "=SUM(RC[-10]:RC[-1])"
NewCol = "Y2:Y" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:Y" & iRecordCount + 1
NewRange = "A1:Y" & iRecordCount + 1
EndRange = "Y" & iRecordCount + 1
Case 11
ActiveCell.FormulaR1C1 = "=SUM(RC[-11]:RC[-1])"
NewCol = "Z2:Z" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
.Range(NewCol).Interior.ColorIndex = 36
FormRange = "A2:Z" & iRecordCount + 1
NewRange = "A1:Z" & iRecordCount + 1
EndRange = "Z" & iRecordCount + 1
Case 12
ActiveCell.FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
NewCol = "AA2:AA" & iRecordCount + 1
Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault
.Range(NewCol).EntireColumn.Font.Bold = True
FormRange = "A2:AA" & iRecordCount + 1
NewRange = "A1:AA" & iRecordCount + 1
EndRange = "AA" & iRecordCount + 1
.Range(NewCol).Interior.ColorIndex = 36
End Select
' This piece adds, formats and fills a grand totals row, formats all
the
' numbers in the sheet correctly and then autofits the entire sheet.
LeftRange = Left(GrandRange, 3)
.Range(FormRange).Select
Selection.NumberFormat = "#,##0"
.Range(GrandRange).Select
Selection.Interior.ColorIndex = 36
Selection.HorizontalAlignment = xlCenter
Selection.Font.Bold = True
Selection.Borders.LineStyle = xlContinuous
.Range(LeftRange).Select
GrandCalc = "=Sum(R[" & iRecordCount * -1 & "]C:R[-1]C)"
Selection.FormulaR1C1 = GrandCalc
Selection.AutoFill Destination:=Range(GrandRange), Type:=xlFillDefault
.Range(GrandRange).Select
.Range(EndRange).Select
Selection.Columns.AutoFit
' This piece deletes the unused sheets.
With wb.Worksheets(2)
.Delete
End With
With wb.Worksheets(2)
.Delete
End With
With .PageSetup ' This piece does some basic page set up type of
formatting.
.LeftFooter = " Report Created &T &D"
.CenterFooter = "&P of &N"
.RightFooter = sPath & sFile & " " & sDate & ".xls"
.LeftMargin = xLApp.InchesToPoints(0.42)
.RightMargin = xLApp.InchesToPoints(0.47)
.TopMargin = xLApp.InchesToPoints(0.52)
.BottomMargin = xLApp.InchesToPoints(0.55)
.HeaderMargin = xLApp.InchesToPoints(0.5)
.FooterMargin = xLApp.InchesToPoints(0.35)
.PrintTitleRows = "$1:$1"
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.Orientation = xlLandscape
.PaperSize = xlPaperLegal
.Zoom = False
.FitToPagesTall = 100
.FitToPagesWide = 1
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
End With
End With
' This Piece saves the file to the appropriate directory.
wb.SaveAs sPath & sFile & " " & sDate & ".xls"
' This piece releases any variable which might still be held in memory
' and closes the excel application
xLApp.Application.Quit
Set wb = Nothing
Set xLApp = Nothing
End Sub
--
Michal Joyce
Project Management IS Analyst
Aflac - Project Management Office
Register To Reply
Bookmarks