S
SHIPP
I am working with Office 2003. I receive an Error Message 1004 Method of
'cells' of object global failed. It happens exactly every other time I run
the code. In other words it runs fine the first time. When I come back and
run it a second time it fails. I run it a third time and it runs fine. The
4th time it fails and so on and so on. Any help would be greatly appreciated.
The code that fails is as follows:
Function ColLetter(ColNumber As Integer) As String
ColLetter = Left(Cells(1, ColNumber).Address(False, False), _
1 - (ColNumber > 26))
End Function
This function is called from the code below...
Public Function fExportToExcel(strQry As String, strPath As String, strFile
As String, strTitle As String)
'***************************************************************************************
'* PROGRAM : PADD
'* CREATED : 06/20/09
'* COMMENTS :
'* PARAMETERS: -
'* RETURNS : -
'* CALLED BY :
'* MODIFIED :
'***************************************************************************************
On Error GoTo HandleErr
Const cstrProcName As String = "modExportExcel - sExportToExcel"
Dim rsOthChgs As dao.Recordset
Dim rsHdr As dao.Recordset
Dim rsInv As dao.Recordset
Dim objXL As Excel.Application
Dim arrHdr1 As Variant
Dim arrHdr2 As Variant
Dim arrHdr2Data As Variant
Dim arrDtl1 As Variant
Dim arrDtl2 As Variant
Dim arrFot As Variant
Dim arrFot1 As Variant
Dim arrFot2 As Variant
Dim intCnt As Integer
Dim strCellLocAdd As String
Dim strCellLoc As String
Dim lngQtyRecordsOthChgs As Long
Dim strTaxID As String
Dim strInv As String
Dim strRow As String
Dim lngHds As Long
Dim lngTtls As Long
Dim lngData As Long
Dim lngFtr As Long
Dim lngTotalData As Long
Dim lngTotalData1 As Long
Dim strLastRow As String
Dim intCurRow As Integer
Dim strCont As String
Dim strSeal As String
Dim strSub As String
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strFull As String
Dim lngQtyRecords As Long
Dim lngTotalRow As Long
Dim lngTotalCol As Long
Dim intCount As Integer
Dim strColBeg As String
Dim strColEnd As String
Set db = CurrentDb
DoCmd.Hourglass True
DoCmd.SetWarnings False
' Create the Excel object
Set objXL = New Excel.Application
Set rs = db.OpenRecordset("qxtbOpenItemsAll", dbOpenDynaset)
lngQtyRecords = DCount("CUSTOMER", "qxtbOpenItemsAll")
lngTotalRow = lngQtyRecords + 3
' Excel worksheet name
strFull = strPath & strFile
With objXL
' Add a workbook and turn off Excel updates
.ScreenUpdating = True
.Visible = False
.Workbooks.Add
.DisplayAlerts = False
' Copy the data to the spreadsheet
.Cells(3, 1).CopyFromRecordset rs
' Format the data
.Cells.Select
.Selection.ColumnWidth = 8
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
.Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Selection.Borders(xlEdgeLeft).Weight = xlThin
.Selection.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
.Selection.Borders(xlEdgeTop).Weight = xlThin
.Selection.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Selection.Borders(xlEdgeBottom).Weight = xlThin
.Selection.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
.Selection.Borders(xlEdgeRight).Weight = xlThin
.Selection.Borders(xlEdgeRight).ColorIndex = xlAutomatic
.Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
.Selection.Borders(xlInsideVertical).Weight = xlThin
.Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
.Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Selection.Borders(xlInsideHorizontal).Weight = xlThin
.Selection.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
' Global font
With .Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
.Cells(lngTotalRow, 2).Select
.ActiveCell.Value = "TOTAL"
For lngTotalCol = 1 To 50
.ActiveCell.Offset(0, 1).Select
.ActiveCell.FormulaR1C1 = "=SUM(R[-" & lngQtyRecords & "]C:R[-1]C)"
Next lngTotalCol
' Format dollars
.Range("C:ZZ").Select
.Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
.Selection.ColumnWidth = 10
' Format company no.
.Range("A:A").Select
.Selection.ColumnWidth = 7
' Format company
.Range("B:B").Select
.Selection.ColumnWidth = 20
' Format totals row
.Rows(lngTotalRow).Select
.Selection.Font.Bold = True
.Selection.Interior.ColorIndex = 6
.Selection.Interior.Pattern = xlSolid
.Selection.Font.ColorIndex = 1
' Label the columns
For intCount = 0 To rs.Fields.Count - 1
.Cells(2, intCount + 1).Value = rs.Fields(intCount).Name
Next intCount
' Format title row
.Rows("2:2").Select
.Selection.Font.Bold = True
.Selection.HorizontalAlignment = xlCenter
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = True
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.IndentLevel = 0
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
.Selection.Interior.ColorIndex = 5
.Selection.Interior.Pattern = xlSolid
.Selection.Font.ColorIndex = 2
.Range("A2").Select
.Selection.HorizontalAlignment = xlLeft
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = False
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.IndentLevel = 0
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
' Delete non-used columns
.Columns(ColLetter(rs.Fields.Count + 1) & ":" &
ColLetter(rs.Fields.Count + 50)).Select
.Selection.Delete Shift:=xlToLeft
' Wrap column B
.Columns("B:B").Select
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = True
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
' Set-Up Header
.Cells(1, 1).Select
.ActiveCell.Value = strTitle & "-" & Str(Date)
.Rows("1:1").Select
.Selection.Font.Name = "Arial"
.Selection.Font.Size = 18
.Selection.Font.Strikethrough = False
.Selection.Font.Superscript = False
.Selection.Font.Subscript = False
.Selection.Font.OutlineFont = False
.Selection.Font.Shadow = False
.Selection.Font.Underline = xlUnderlineStyleNone
.Selection.Font.Bold = True
' Page set-up
With ActiveSheet.PageSetup
.PrintTitleRows = "$2:$2"
.PrintTitleColumns = "$A:$B"
End With
' Set up the page for printing
.ActiveSheet.PageSetup.PrintArea = "$C$3:$" & ColLetter(rs.Fields.Count)
& "$" & lngTotalRow
With .ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""&20" & strTitle
.RightHeader = ""
.LeftFooter = "&8&D"
.CenterFooter = ""
.RightFooter = "&8Page &P of &N"
.LeftMargin = .Application.InchesToPoints(0.25)
.RightMargin = .Application.InchesToPoints(0.25)
.TopMargin = .Application.InchesToPoints(0.75)
.BottomMargin = .Application.InchesToPoints(0.5)
.HeaderMargin = .Application.InchesToPoints(0.35)
.FooterMargin = .Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
.Range("A1").Select
.ActiveWorkbook.SaveAs (strFull)
End With
ExitHere:
DoCmd.SetWarnings True
DoCmd.Hourglass False
objXL.Quit
Set objXL = Nothing
rs.Close
Set rs = Nothing
Exit Function
HandleErr:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical,
cstrProcName
End Select
GoTo ExitHere
End Function
'cells' of object global failed. It happens exactly every other time I run
the code. In other words it runs fine the first time. When I come back and
run it a second time it fails. I run it a third time and it runs fine. The
4th time it fails and so on and so on. Any help would be greatly appreciated.
The code that fails is as follows:
Function ColLetter(ColNumber As Integer) As String
ColLetter = Left(Cells(1, ColNumber).Address(False, False), _
1 - (ColNumber > 26))
End Function
This function is called from the code below...
Public Function fExportToExcel(strQry As String, strPath As String, strFile
As String, strTitle As String)
'***************************************************************************************
'* PROGRAM : PADD
'* CREATED : 06/20/09
'* COMMENTS :
'* PARAMETERS: -
'* RETURNS : -
'* CALLED BY :
'* MODIFIED :
'***************************************************************************************
On Error GoTo HandleErr
Const cstrProcName As String = "modExportExcel - sExportToExcel"
Dim rsOthChgs As dao.Recordset
Dim rsHdr As dao.Recordset
Dim rsInv As dao.Recordset
Dim objXL As Excel.Application
Dim arrHdr1 As Variant
Dim arrHdr2 As Variant
Dim arrHdr2Data As Variant
Dim arrDtl1 As Variant
Dim arrDtl2 As Variant
Dim arrFot As Variant
Dim arrFot1 As Variant
Dim arrFot2 As Variant
Dim intCnt As Integer
Dim strCellLocAdd As String
Dim strCellLoc As String
Dim lngQtyRecordsOthChgs As Long
Dim strTaxID As String
Dim strInv As String
Dim strRow As String
Dim lngHds As Long
Dim lngTtls As Long
Dim lngData As Long
Dim lngFtr As Long
Dim lngTotalData As Long
Dim lngTotalData1 As Long
Dim strLastRow As String
Dim intCurRow As Integer
Dim strCont As String
Dim strSeal As String
Dim strSub As String
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strFull As String
Dim lngQtyRecords As Long
Dim lngTotalRow As Long
Dim lngTotalCol As Long
Dim intCount As Integer
Dim strColBeg As String
Dim strColEnd As String
Set db = CurrentDb
DoCmd.Hourglass True
DoCmd.SetWarnings False
' Create the Excel object
Set objXL = New Excel.Application
Set rs = db.OpenRecordset("qxtbOpenItemsAll", dbOpenDynaset)
lngQtyRecords = DCount("CUSTOMER", "qxtbOpenItemsAll")
lngTotalRow = lngQtyRecords + 3
' Excel worksheet name
strFull = strPath & strFile
With objXL
' Add a workbook and turn off Excel updates
.ScreenUpdating = True
.Visible = False
.Workbooks.Add
.DisplayAlerts = False
' Copy the data to the spreadsheet
.Cells(3, 1).CopyFromRecordset rs
' Format the data
.Cells.Select
.Selection.ColumnWidth = 8
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
.Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Selection.Borders(xlEdgeLeft).Weight = xlThin
.Selection.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
.Selection.Borders(xlEdgeTop).Weight = xlThin
.Selection.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Selection.Borders(xlEdgeBottom).Weight = xlThin
.Selection.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
.Selection.Borders(xlEdgeRight).Weight = xlThin
.Selection.Borders(xlEdgeRight).ColorIndex = xlAutomatic
.Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
.Selection.Borders(xlInsideVertical).Weight = xlThin
.Selection.Borders(xlInsideVertical).ColorIndex = xlAutomatic
.Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Selection.Borders(xlInsideHorizontal).Weight = xlThin
.Selection.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
' Global font
With .Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
.Cells(lngTotalRow, 2).Select
.ActiveCell.Value = "TOTAL"
For lngTotalCol = 1 To 50
.ActiveCell.Offset(0, 1).Select
.ActiveCell.FormulaR1C1 = "=SUM(R[-" & lngQtyRecords & "]C:R[-1]C)"
Next lngTotalCol
' Format dollars
.Range("C:ZZ").Select
.Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
.Selection.ColumnWidth = 10
' Format company no.
.Range("A:A").Select
.Selection.ColumnWidth = 7
' Format company
.Range("B:B").Select
.Selection.ColumnWidth = 20
' Format totals row
.Rows(lngTotalRow).Select
.Selection.Font.Bold = True
.Selection.Interior.ColorIndex = 6
.Selection.Interior.Pattern = xlSolid
.Selection.Font.ColorIndex = 1
' Label the columns
For intCount = 0 To rs.Fields.Count - 1
.Cells(2, intCount + 1).Value = rs.Fields(intCount).Name
Next intCount
' Format title row
.Rows("2:2").Select
.Selection.Font.Bold = True
.Selection.HorizontalAlignment = xlCenter
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = True
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.IndentLevel = 0
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
.Selection.Interior.ColorIndex = 5
.Selection.Interior.Pattern = xlSolid
.Selection.Font.ColorIndex = 2
.Range("A2").Select
.Selection.HorizontalAlignment = xlLeft
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = False
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.IndentLevel = 0
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
' Delete non-used columns
.Columns(ColLetter(rs.Fields.Count + 1) & ":" &
ColLetter(rs.Fields.Count + 50)).Select
.Selection.Delete Shift:=xlToLeft
' Wrap column B
.Columns("B:B").Select
.Selection.VerticalAlignment = xlBottom
.Selection.WrapText = True
.Selection.Orientation = 0
.Selection.AddIndent = False
.Selection.ShrinkToFit = False
.Selection.ReadingOrder = xlContext
.Selection.MergeCells = False
' Set-Up Header
.Cells(1, 1).Select
.ActiveCell.Value = strTitle & "-" & Str(Date)
.Rows("1:1").Select
.Selection.Font.Name = "Arial"
.Selection.Font.Size = 18
.Selection.Font.Strikethrough = False
.Selection.Font.Superscript = False
.Selection.Font.Subscript = False
.Selection.Font.OutlineFont = False
.Selection.Font.Shadow = False
.Selection.Font.Underline = xlUnderlineStyleNone
.Selection.Font.Bold = True
' Page set-up
With ActiveSheet.PageSetup
.PrintTitleRows = "$2:$2"
.PrintTitleColumns = "$A:$B"
End With
' Set up the page for printing
.ActiveSheet.PageSetup.PrintArea = "$C$3:$" & ColLetter(rs.Fields.Count)
& "$" & lngTotalRow
With .ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""&20" & strTitle
.RightHeader = ""
.LeftFooter = "&8&D"
.CenterFooter = ""
.RightFooter = "&8Page &P of &N"
.LeftMargin = .Application.InchesToPoints(0.25)
.RightMargin = .Application.InchesToPoints(0.25)
.TopMargin = .Application.InchesToPoints(0.75)
.BottomMargin = .Application.InchesToPoints(0.5)
.HeaderMargin = .Application.InchesToPoints(0.35)
.FooterMargin = .Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
.Range("A1").Select
.ActiveWorkbook.SaveAs (strFull)
End With
ExitHere:
DoCmd.SetWarnings True
DoCmd.Hourglass False
objXL.Quit
Set objXL = Nothing
rs.Close
Set rs = Nothing
Exit Function
HandleErr:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical,
cstrProcName
End Select
GoTo ExitHere
End Function