Excel automation error

[scottfarcus]

I am automating the creation of a spreadsheet using data from my db.

The data "merge" works beautifully when I run the code for the first time. If I attempt to run the code a second time within the same session, I get two different errors.

Errors:

1) #1004 - Method 'Cells' of object '_Global' failed.
2) #1004 - Application-defined or object-drfined error

If someome could also tell me why my instances of Excel are not being properly killed, I'd appretiate that. I think that may be my problem that I'm not properly destroying instances of Excel before trying to create new ones.

I'd appreciate any input. Thanks!

Code follows:

Private Sub cmdCalendar_Click()
On Error GoTo ErrHandle

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook

Dim db As DAO.Database
Dim rsStaff As DAO.Recordset
Dim rsStaffLeave As DAO.Recordset
Dim strSQL As String

Dim dteStart As Date
Dim dteEnd As Date
Dim intParticipant

Dim iCell As Integer
Dim iStaff As Integer
Dim iStaffCount As Integer
Dim i As Integer

Dim iCol As Integer
Dim iRow As Integer

Dim iEndRow As Integer
Dim iEndCol As Integer

Dim x As Variant
Dim iDate As Variant

Dim boolDest As Boolean
Dim boolMonth As Boolean

Dim strMonth As String


Set db = CurrentDb
Set rsStaff = db.OpenRecordset("SELECT tblParticipant.ParticipantID, [LName] + ', ' + [FName] AS FullName FROM tblParticipant ORDER BY [LName], [FName];")
Set rsStaffLeave = db.OpenRecordset("SELECT tblParticipantLeave.ParticipantID, tblParticipantLeave.LeaveBegin, tblParticipantLeave.LeaveEnd, tblParticipantLeave.Purpose, tblParticipantLeave.Destination, IIf([Purpose]='Vacation',4,IIf([Purpose]='TDY',3,5)) AS PurposeColor FROM tblParticipantLeave ORDER BY LeaveBegin;")

iStaffCount = rsStaff.RecordCount

dteStart = txtStartDate
dteEnd = txtEndDate
iCell = 3

Screen.MousePointer = 11

If xlApp Is Nothing Then
Set xlApp = GetObject("", "Excel.Application")
End If

Set xlBook = xlApp.Workbooks.Add

'Populate dates
With xlBook.Sheets(1)
For iDate = dteStart To dteEnd
.Cells(1, iCell) = iDate
.Cells(1, iCell).Font.Color = vbWhite
.Cells(2, iCell) = Format(iDate, "mmmm")
.Cells(3, iCell) = Format(iDate, "d")
iCell = iCell + 1
Next
End With

'Populate staff names
With xlBook.Sheets(1)
For iStaff = 1 To iStaffCount
.Cells(iStaff + 3, 1) = rsStaff.Fields("ParticipantID")
.Cells(iStaff + 3, 2) = rsStaff.Fields("FullName")
rsStaff.MoveNext
Next
End With

xlBook.Sheets(1).Range("C4").Select

'Find last populated row/column intersection to use as range later
With xlBook.Sheets(1)
For Each x In .Range("A4:A500")
If IsEmpty(x) Then
iEndRow = x.Row - 1
Exit For
End If
Next

For Each x In .Range("C2:IV2")
If IsEmpty(x) Then
iEndCol = x.Column - 1
Exit For
End If
Next
'MsgBox "Last populated column: " & iEndCol & vbCrLf & "Last populated row: " & iEndRow
End With

'Autofit columns
With xlBook.Sheets(1)
.Columns("A:B").AutoFit
.Columns("C:IV").ColumnWidth = "2.26"
End With

'Color code and populate cells
With xlBook.Sheets(1)
For i = 1 To rsStaffLeave.RecordCount
intParticipant = rsStaffLeave.Fields("ParticipantID")
dteStart = rsStaffLeave.Fields("LeaveBegin")
dteEnd = rsStaffLeave.Fields("LeaveEnd")
boolDest = False

***********************************
*ERROR HAPPENS WITHIN NEXT FOR LOOP*
***********************************

For Each x In .Range("A4:A" & iEndRow)
If x.Value = intParticipant Then
iRow = x.Row
Exit For
End If
Next

For Each x In .Range(Cells(iRow, 3), Cells(iRow, iEndCol))
If .Cells(1, x.Column) >= dteStart And .Cells(1, x.Column) <= dteEnd Then
x.Interior.ColorIndex = rsStaffLeave.Fields("PurposeColor")
If boolDest = False Then
x.Font.Size = 7
x.Value = rsStaffLeave.Fields("Destination")
boolDest = True
End If
End If
Next
rsStaffLeave.MoveNext
Next


For Each x In .Range(Cells(2, 3), Cells(2, iEndCol + 1))
If strMonth = "" Then
strMonth = x.Value
iCol = x.Column
x.Font.Bold = True
ElseIf strMonth = x.Value Then
x.Value = ""
Else
.Range(Cells(2, iCol), Cells(2, x.Column - 1)).Merge
strMonth = x.Value
iCol = x.Column
x.Font.Bold = True
End If
Next

End With

xlApp.Visible = True
xlApp.ActiveWindow.FreezePanes = True

Screen.MousePointer = 0
Set xlBook = Nothing
Set xlApp = Nothing
txtStatus = ""

Exit Sub

ErrHandle:
Screen.MousePointer = 0

MsgBox "Error: " & Err.Number & " - " & Err.Description _
& "Sorry for the inconvenience."

Set xlBook = Nothing

Set xlApp = Nothing
Exit Sub

End Sub

 

[mark curtis]

not a mega expert in this area but could one problem be:

For Each x In .Range("A4:A" & iEndRow)

For Each x In .Range("A4:A" , iEndRow)