G

#### Guest

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" & iRecordCount + 1

NewColTop = "P11"

NextDown = "P22"

Case 2

ClearRange = "Q1:Z" & iRecordCount + 1

ColRange = "P1" & 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" & iRecordCount + 1

Selection.AutoFill Destination:=Range(NewCol), Type:=xlFillDefault

.Range(NewCol).EntireColumn.Font.Bold = True

.Range(NewCol).Interior.ColorIndex = 36

FormRange = "A2" & iRecordCount + 1

NewRange = "A1" & 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