G
Guest
I have the following code that creates an Excel worksheet based on data from
a Access table. The first time I run this it runs fine. The next time I run
it (during the same Access session) it gives me a 91 run-time error on the
line indicated below. Then the next time I run it, it runs fine. So,
bottom-line is that it runs fine every other time I run it, but gives me this
error every other time. I think I need to close down an object or something.
The row that it gives me the error message on doesn't seem to be related to
the problem.
======================================
Sub GenerateCPSPortfolioSS2()
Set appExcel = CreateObject("Excel.Application")
'Set up data source
Dim mDB As Database
Set mDB = CurrentDb
Dim rsPI As Recordset 'Project Info
Set rsPI = mDB.OpenRecordset( _
"SELECT tblProject.projName, " & _
"tblProject.projClientContact, " & _
"tblProject.projPM , " & _
"tblRAGStatus.statColorNumber, " & _
"tblProject.projInitiationStartDate, " & _
"tblProject.projPostImplementationDate, " & _
"tblProject.projPostImplementationComp, " & _
"tblProject.projDescription, " & _
"tblProject.projEntity " & _
"FROM tblRAGStatus INNER JOIN tblProject ON tblRAGStatus.statID =
tblProject.projRAGStatus " & _
"WHERE tblProject.projActive = True " & _
"ORDER BY IsNull([projPostImplementationDate]) DESC ,
tblProject.projPostImplementationDate")
'Set Up the Spreadsheet Headers
appExcel.Visible = True
appExcel.Workbooks.Add
'Set global attributes
appExcel.Cells.Font.Name = "Arial"
appExcel.Cells.Font.Size = 8
appExcel.ActiveSheet.PageSetup.Orientation = xlLandscape
appExcel.ActiveSheet.PageSetup.FitToPagesTall = False
appExcel.ActiveSheet.PageSetup.FitToPagesWide = 1
appExcel.ActiveSheet.PageSetup.Zoom = False
' This next row is the row that it gives me an error message on (yellow
highlight)
appExcel.ActiveSheet.PageSetup.PrintTitleRows =
ActiveSheet.Rows(2).Address
'Set column widths
appExcel.Columns("A").ColumnWidth = 7
appExcel.Columns("B").ColumnWidth = 7
appExcel.Columns("C").ColumnWidth = 7
appExcel.Columns("D").ColumnWidth = 7
appExcel.Columns("E").ColumnWidth = 10
appExcel.Columns("F").ColumnWidth = 7
appExcel.Columns("G").ColumnWidth = 30
appExcel.Columns("H").ColumnWidth = 35
appExcel.Columns("I").ColumnWidth = 6
appExcel.Columns("J").ColumnWidth = 8
appExcel.Columns("K").ColumnWidth = 6
appExcel.Columns("L").ColumnWidth = 17
appExcel.Columns("M").ColumnWidth = 5
appExcel.Columns("N").ColumnWidth = 9
appExcel.Columns("O").ColumnWidth = 7
appExcel.Columns("P").ColumnWidth = 7
appExcel.Columns("Q").ColumnWidth = 7
appExcel.Columns("R").ColumnWidth = 10
appExcel.Columns("S").ColumnWidth = 10
appExcel.Columns("T").ColumnWidth = 7
appExcel.Columns("P").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("Q").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("R").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("S").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("G").WrapText = True
appExcel.Columns("H").WrapText = True
appExcel.Columns("A:T").VerticalAlignment = xlVAlignTop
appExcel.Range("A2", "T2").HorizontalAlignment = xlCenter
appExcel.Range("A2", "T2").Interior.Color = 32768
appExcel.Range("A2", "T2").Font.Color = vbWhite
appExcel.Range("A2", "T2").Borders.LineStyle = xlContinuous
appExcel.Range("A1").Font.Size = 12
appExcel.Range("A1").Font.Italic = True
appExcel.Range("A1").Interior.Color = vbWhite
appExcel.Range("A1").Value = "CPS Project Portfolio (as of " &
Format(Date, "mm/dd") & ")"
appExcel.Rows(2).WrapText = True
appExcel.Rows(2).RowHeight = 33.75
appExcel.Range("A2") = "Scrub Status"
appExcel.Range("B2") = "Proposed Portfolio"
appExcel.Range("C2") = "Notes"
appExcel.Range("D2") = "Briefs"
appExcel.Range("E2") = "Project Status"
appExcel.Range("F2") = "Proj ID or Number"
appExcel.Range("G2") = "Project Name"
appExcel.Range("H2") = "Project Description"
appExcel.Range("I2") = "Original Portfolio"
appExcel.Range("J2") = "Primary Business Unit"
appExcel.Range("K2") = "Primary System Target"
appExcel.Range("L2") = "Project Sponsor"
appExcel.Range("M2") = "PDLC Project Phase"
appExcel.Range("N2") = "Total IT Work Effort"
appExcel.Range("O2") = "Total Business Effort"
appExcel.Range("P2") = "Business Case Approval Date"
appExcel.Range("Q2") = "Project Approval Date"
appExcel.Range("R2") = "Kick-Off Date"
appExcel.Range("S2") = "Target Go Live Date"
appExcel.Range("T2") = "Business Case#"
appExcel.Range("A3").Activate
ActiveWindow.FreezePanes = True
'mRowCount is used to track what spreadsheet row we are on
mRowCount = 3
'mCircle will be used to hold the circle shape, mArrow will be used
to hold the arrow shape
Dim mCircle As Excel.Shape
Dim mArrow As Excel.Shape
'mSumRowHeight is used to calculate where to position the graphic
elements
Dim mSumRowHeight As Single
rsPI.MoveFirst
'OK. Let's cycle through the records and build the body of the
spreadsheet
While Not rsPI.EOF
appExcel.Cells(mRowCount, 7) = rsPI!projName
appExcel.Cells(mRowCount, 10) = rsPI!projEntity
appExcel.Cells(mRowCount, 8) = rsPI!projDescription
If IsNumeric(InStr(1, rsPI!projClientContact, vbCrLf)) Then
If InStr(1, rsPI!projClientContact, vbCrLf) <> 0 Then
appExcel.Cells(mRowCount, 12) =
Left(rsPI!projClientContact, InStr(1, rsPI!projClientContact, vbCrLf) - 1)
Else
appExcel.Cells(mRowCount, 12) = rsPI!projClientContact
End If
Else
appExcel.Cells(mRowCount, 12) = rsPI!projClientContact
End If
'Draw Shapes
Set mCircle =
appExcel.ActiveSheet.Shapes.AddShape(Type:=msoShapeOval,
Left:=Cells(mRowCount, 5).Left + 5, Top:=Cells(mRowCount, 5).Top + 5,
Width:=10, Height:=10)
mCircle.Fill.ForeColor.RGB = RGB(GetRGB(rsPI!statColorNumber,
1), GetRGB(rsPI!statColorNumber, 2), GetRGB(rsPI!statColorNumber, 3))
Set mArrow =
appExcel.ActiveSheet.Shapes.AddShape(Type:=msoShapeLeftRightArrow,
Left:=Cells(mRowCount, 5).Left + 20, Top:=Cells(mRowCount, 5).Top + 5,
Width:=23, Height:=10)
mArrow.Fill.ForeColor.RGB = RGB(168, 168, 168)
appExcel.Cells(mRowCount, 18) = rsPI!projInitiationStartDate
appExcel.Cells(mRowCount, 19) = rsPI!projPostImplementationDate
'If rsPI!projPostImplementationDate = True Then
appExcel.Cells(mRowCount, 8) = rsPI!projPostImplementationDate
appExcel.Range(Cells(mRowCount, 1), Cells(mRowCount,
20)).Borders.LineStyle = xlContinuous
mRowCount = mRowCount + 1
'appExcel.Range(Cells(mRowCount, 2), Cells(mRowCount,
9)).Borders.LineStyle = xlContinuous
'mRowCount = mRowCount + 1
mSumRowHeight = mSumRowHeight + appExcel.Cells(mRowCount,
2).RowHeight
rsPI.MoveNext
'mRecCount = mRecCount + 1
Wend
End Sub
a Access table. The first time I run this it runs fine. The next time I run
it (during the same Access session) it gives me a 91 run-time error on the
line indicated below. Then the next time I run it, it runs fine. So,
bottom-line is that it runs fine every other time I run it, but gives me this
error every other time. I think I need to close down an object or something.
The row that it gives me the error message on doesn't seem to be related to
the problem.
======================================
Sub GenerateCPSPortfolioSS2()
Set appExcel = CreateObject("Excel.Application")
'Set up data source
Dim mDB As Database
Set mDB = CurrentDb
Dim rsPI As Recordset 'Project Info
Set rsPI = mDB.OpenRecordset( _
"SELECT tblProject.projName, " & _
"tblProject.projClientContact, " & _
"tblProject.projPM , " & _
"tblRAGStatus.statColorNumber, " & _
"tblProject.projInitiationStartDate, " & _
"tblProject.projPostImplementationDate, " & _
"tblProject.projPostImplementationComp, " & _
"tblProject.projDescription, " & _
"tblProject.projEntity " & _
"FROM tblRAGStatus INNER JOIN tblProject ON tblRAGStatus.statID =
tblProject.projRAGStatus " & _
"WHERE tblProject.projActive = True " & _
"ORDER BY IsNull([projPostImplementationDate]) DESC ,
tblProject.projPostImplementationDate")
'Set Up the Spreadsheet Headers
appExcel.Visible = True
appExcel.Workbooks.Add
'Set global attributes
appExcel.Cells.Font.Name = "Arial"
appExcel.Cells.Font.Size = 8
appExcel.ActiveSheet.PageSetup.Orientation = xlLandscape
appExcel.ActiveSheet.PageSetup.FitToPagesTall = False
appExcel.ActiveSheet.PageSetup.FitToPagesWide = 1
appExcel.ActiveSheet.PageSetup.Zoom = False
' This next row is the row that it gives me an error message on (yellow
highlight)
appExcel.ActiveSheet.PageSetup.PrintTitleRows =
ActiveSheet.Rows(2).Address
'Set column widths
appExcel.Columns("A").ColumnWidth = 7
appExcel.Columns("B").ColumnWidth = 7
appExcel.Columns("C").ColumnWidth = 7
appExcel.Columns("D").ColumnWidth = 7
appExcel.Columns("E").ColumnWidth = 10
appExcel.Columns("F").ColumnWidth = 7
appExcel.Columns("G").ColumnWidth = 30
appExcel.Columns("H").ColumnWidth = 35
appExcel.Columns("I").ColumnWidth = 6
appExcel.Columns("J").ColumnWidth = 8
appExcel.Columns("K").ColumnWidth = 6
appExcel.Columns("L").ColumnWidth = 17
appExcel.Columns("M").ColumnWidth = 5
appExcel.Columns("N").ColumnWidth = 9
appExcel.Columns("O").ColumnWidth = 7
appExcel.Columns("P").ColumnWidth = 7
appExcel.Columns("Q").ColumnWidth = 7
appExcel.Columns("R").ColumnWidth = 10
appExcel.Columns("S").ColumnWidth = 10
appExcel.Columns("T").ColumnWidth = 7
appExcel.Columns("P").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("Q").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("R").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("S").NumberFormat = "mm/dd/yyyy"
appExcel.Columns("G").WrapText = True
appExcel.Columns("H").WrapText = True
appExcel.Columns("A:T").VerticalAlignment = xlVAlignTop
appExcel.Range("A2", "T2").HorizontalAlignment = xlCenter
appExcel.Range("A2", "T2").Interior.Color = 32768
appExcel.Range("A2", "T2").Font.Color = vbWhite
appExcel.Range("A2", "T2").Borders.LineStyle = xlContinuous
appExcel.Range("A1").Font.Size = 12
appExcel.Range("A1").Font.Italic = True
appExcel.Range("A1").Interior.Color = vbWhite
appExcel.Range("A1").Value = "CPS Project Portfolio (as of " &
Format(Date, "mm/dd") & ")"
appExcel.Rows(2).WrapText = True
appExcel.Rows(2).RowHeight = 33.75
appExcel.Range("A2") = "Scrub Status"
appExcel.Range("B2") = "Proposed Portfolio"
appExcel.Range("C2") = "Notes"
appExcel.Range("D2") = "Briefs"
appExcel.Range("E2") = "Project Status"
appExcel.Range("F2") = "Proj ID or Number"
appExcel.Range("G2") = "Project Name"
appExcel.Range("H2") = "Project Description"
appExcel.Range("I2") = "Original Portfolio"
appExcel.Range("J2") = "Primary Business Unit"
appExcel.Range("K2") = "Primary System Target"
appExcel.Range("L2") = "Project Sponsor"
appExcel.Range("M2") = "PDLC Project Phase"
appExcel.Range("N2") = "Total IT Work Effort"
appExcel.Range("O2") = "Total Business Effort"
appExcel.Range("P2") = "Business Case Approval Date"
appExcel.Range("Q2") = "Project Approval Date"
appExcel.Range("R2") = "Kick-Off Date"
appExcel.Range("S2") = "Target Go Live Date"
appExcel.Range("T2") = "Business Case#"
appExcel.Range("A3").Activate
ActiveWindow.FreezePanes = True
'mRowCount is used to track what spreadsheet row we are on
mRowCount = 3
'mCircle will be used to hold the circle shape, mArrow will be used
to hold the arrow shape
Dim mCircle As Excel.Shape
Dim mArrow As Excel.Shape
'mSumRowHeight is used to calculate where to position the graphic
elements
Dim mSumRowHeight As Single
rsPI.MoveFirst
'OK. Let's cycle through the records and build the body of the
spreadsheet
While Not rsPI.EOF
appExcel.Cells(mRowCount, 7) = rsPI!projName
appExcel.Cells(mRowCount, 10) = rsPI!projEntity
appExcel.Cells(mRowCount, 8) = rsPI!projDescription
If IsNumeric(InStr(1, rsPI!projClientContact, vbCrLf)) Then
If InStr(1, rsPI!projClientContact, vbCrLf) <> 0 Then
appExcel.Cells(mRowCount, 12) =
Left(rsPI!projClientContact, InStr(1, rsPI!projClientContact, vbCrLf) - 1)
Else
appExcel.Cells(mRowCount, 12) = rsPI!projClientContact
End If
Else
appExcel.Cells(mRowCount, 12) = rsPI!projClientContact
End If
'Draw Shapes
Set mCircle =
appExcel.ActiveSheet.Shapes.AddShape(Type:=msoShapeOval,
Left:=Cells(mRowCount, 5).Left + 5, Top:=Cells(mRowCount, 5).Top + 5,
Width:=10, Height:=10)
mCircle.Fill.ForeColor.RGB = RGB(GetRGB(rsPI!statColorNumber,
1), GetRGB(rsPI!statColorNumber, 2), GetRGB(rsPI!statColorNumber, 3))
Set mArrow =
appExcel.ActiveSheet.Shapes.AddShape(Type:=msoShapeLeftRightArrow,
Left:=Cells(mRowCount, 5).Left + 20, Top:=Cells(mRowCount, 5).Top + 5,
Width:=23, Height:=10)
mArrow.Fill.ForeColor.RGB = RGB(168, 168, 168)
appExcel.Cells(mRowCount, 18) = rsPI!projInitiationStartDate
appExcel.Cells(mRowCount, 19) = rsPI!projPostImplementationDate
'If rsPI!projPostImplementationDate = True Then
appExcel.Cells(mRowCount, 8) = rsPI!projPostImplementationDate
appExcel.Range(Cells(mRowCount, 1), Cells(mRowCount,
20)).Borders.LineStyle = xlContinuous
mRowCount = mRowCount + 1
'appExcel.Range(Cells(mRowCount, 2), Cells(mRowCount,
9)).Borders.LineStyle = xlContinuous
'mRowCount = mRowCount + 1
mSumRowHeight = mSumRowHeight + appExcel.Cells(mRowCount,
2).RowHeight
rsPI.MoveNext
'mRecCount = mRecCount + 1
Wend
End Sub