As a test, I added WB.Close right before I set the XL and WB objects to Nothing, but I am still getting Run-time error 1004 every other time I run the code. I'm going to post the code for the entire module, in case there is something in there that I haven't posted yet that might be the cause. The first sub to run is CreatePayrollLog. It is passed a variable from the OnClick of a button on one of my forms.
Code:
Option Compare Database
Option Explicit
Dim XL As Object
Dim WB As Object
Dim FileToOpen As String
Sub CreatePayrollLog(JobID As Integer)
Dim HighlightYellow As Boolean
Dim Answer As Variant
HighlightYellow = False
Answer = MsgBox("Would you like any existing entries on the log to be highlighted in yellow?", vbYesNo + vbQuestion + vbDefaultButton2, "Highlight Existing Entries")
If Answer = vbNo Then
HighlightYellow = False
ElseIf Answer = vbYes Then
HighlightYellow = True
End If
Call OpenPayrollLogExcelFile
Call AddPayrollData(JobID, HighlightYellow)
DoCmd.Beep
MsgBox "The file is open and the payroll data has been added. Don't forget to save the file."
WB.Close
Set WB = Nothing
Set XL = Nothing
End Sub
Sub AddPayrollData(JobID As Integer, Optional HighlightYellow As Boolean)
Dim rstQ_PayrollLog As Recordset
Dim FoundEmptyRow As Boolean
Dim RowNumber As Integer
Dim EmptyRow As Integer
Dim LCounter As Integer
Dim FoundMatchingEntry As Boolean
Dim PositionAndOCC As String
FoundEmptyRow = False
FoundMatchingEntry = False
RowNumber = 8
EmptyRow = 0
Set rstQ_PayrollLog = CurrentDb.OpenRecordset(Name:="Q_PayrollLog", Type:=RecordsetTypeEnum.dbOpenSnapshot)
rstQ_PayrollLog.MoveLast
rstQ_PayrollLog.MoveFirst
With XL
.Sheets("PayrollLog").Activate
Do While Not rstQ_PayrollLog.EOF
FoundMatchingEntry = False
If rstQ_PayrollLog.Fields("JobID") = JobID Then
If .Range("A1") = "[company name here]" Then .Range("A1") = rstQ_PayrollLog.Fields("CompanyName")
If .Range("A2") = "[job title here]" Then .Range("A2") = rstQ_PayrollLog.Fields("JobTitle")
Do While FoundEmptyRow = False
If IsEmpty(.Range("A" & RowNumber)) Then
FoundEmptyRow = True
Else
If HighlightYellow = True Then .Range("A" & RowNumber & ":M" & RowNumber).Interior.ColorIndex = 6 'Yellow
RowNumber = RowNumber + 1
End If
Loop
If EmptyRow = 0 Then EmptyRow = RowNumber
'now i need it to scroll through each record in the query and check to see if this record is already on the log.
'if it's not, it should write it to next empty row.
If RowNumber > 8 Then
For LCounter = 8 To (RowNumber - 1)
If rstQ_PayrollLog.Fields("TimecardID") = .Range("N" & LCounter) Then
FoundMatchingEntry = True
Exit For
End If
Next
End If
If FoundMatchingEntry = True Then
If IsNull(rstQ_PayrollLog.Fields("OCCCode")) Or rstQ_PayrollLog.Fields("OCCCode") = "" Then
PositionAndOCC = rstQ_PayrollLog.Fields("PositionTitle")
Else
PositionAndOCC = rstQ_PayrollLog.Fields("PositionTitle") & " / " & rstQ_PayrollLog.Fields("OCCCode")
End If
.Range("A" & LCounter) = rstQ_PayrollLog.Fields("FullName")
.Range("B" & LCounter) = PositionAndOCC
.Range("C" & LCounter) = Val(rstQ_PayrollLog.Fields("PositionAcctCode"))
.Range("D" & LCounter) = rstQ_PayrollLog.Fields("WeekEnding")
.Range("E" & LCounter) = rstQ_PayrollLog.Fields("NumberDaysWorked")
.Range("F" & LCounter) = rstQ_PayrollLog.Fields("Rate")
.Range("G" & LCounter) = rstQ_PayrollLog.Fields("1XTotalAmt")
.Range("H" & LCounter) = rstQ_PayrollLog.Fields("1point5XTotalAmt")
.Range("I" & LCounter) = rstQ_PayrollLog.Fields("2X3X")
.Range("J" & LCounter) = rstQ_PayrollLog.Fields("MPTotalAmt")
.Range("K" & LCounter) = rstQ_PayrollLog.Fields("TOTALAMT")
.Range("L" & LCounter) = rstQ_PayrollLog.Fields("BoxRentalTotalAmt")
.Range("M" & LCounter) = rstQ_PayrollLog.Fields("MileageTotalAmt")
.Range("N" & LCounter) = rstQ_PayrollLog.Fields("TimecardID")
.Range("A" & LCounter & ":M" & LCounter).ShrinkToFit = True
If LCounter > 8 Then .Range("A" & LCounter & ":M" & LCounter).Borders.LineStyle = xlContinuous
.Range("C" & LCounter).HorizontalAlignment = xlLeft
.Range("D" & LCounter).NumberFormat = "mm/dd/yy"
.Range("D" & LCounter).HorizontalAlignment = xlLeft
.Range("E" & LCounter).HorizontalAlignment = xlCenter
.Range("F" & LCounter).NumberFormat = "0.0000"
.Range("F" & LCounter).HorizontalAlignment = xlCenter
If .Range("I" & LCounter) = "" Or IsEmpty(.Range("I" & LCounter)) Then
.Range("I" & LCounter) = .Range("I" & LCounter)
Else
.Range("I" & LCounter) = RemoveFirstChar(.Range("I" & LCounter))
End If
.Range("G" & LCounter & ":M" & LCounter).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
.Range("K" & LCounter).Font.Bold = True
.Range("K" & LCounter).Font.Size = 12
Else
If IsNull(rstQ_PayrollLog.Fields("OCCCode")) Or rstQ_PayrollLog.Fields("OCCCode") = "" Then
PositionAndOCC = rstQ_PayrollLog.Fields("PositionTitle")
Else
PositionAndOCC = rstQ_PayrollLog.Fields("PositionTitle") & " / " & rstQ_PayrollLog.Fields("OCCCode")
End If
.Range("A" & EmptyRow) = rstQ_PayrollLog.Fields("FullName")
.Range("B" & EmptyRow) = PositionAndOCC
.Range("C" & EmptyRow) = Val(rstQ_PayrollLog.Fields("PositionAcctCode"))
.Range("D" & EmptyRow) = rstQ_PayrollLog.Fields("WeekEnding")
.Range("E" & EmptyRow) = rstQ_PayrollLog.Fields("NumberDaysWorked")
.Range("F" & EmptyRow) = rstQ_PayrollLog.Fields("Rate")
.Range("G" & EmptyRow) = rstQ_PayrollLog.Fields("1XTotalAmt")
.Range("H" & EmptyRow) = rstQ_PayrollLog.Fields("1point5XTotalAmt")
.Range("I" & EmptyRow) = rstQ_PayrollLog.Fields("2X3X")
.Range("J" & EmptyRow) = rstQ_PayrollLog.Fields("MPTotalAmt")
.Range("K" & EmptyRow) = rstQ_PayrollLog.Fields("TOTALAMT")
.Range("L" & EmptyRow) = rstQ_PayrollLog.Fields("BoxRentalTotalAmt")
.Range("M" & EmptyRow) = rstQ_PayrollLog.Fields("MileageTotalAmt")
.Range("N" & EmptyRow) = rstQ_PayrollLog.Fields("TimecardID")
.Range("A" & EmptyRow & ":M" & EmptyRow).ShrinkToFit = True
If EmptyRow > 8 Then .Range("A" & EmptyRow & ":M" & EmptyRow).Borders.LineStyle = xlContinuous
.Range("C" & EmptyRow).HorizontalAlignment = xlLeft
.Range("D" & EmptyRow).NumberFormat = "mm/dd/yy"
.Range("D" & EmptyRow).HorizontalAlignment = xlLeft
.Range("E" & EmptyRow).HorizontalAlignment = xlCenter
.Range("F" & EmptyRow).NumberFormat = "0.0000"
.Range("F" & EmptyRow).HorizontalAlignment = xlCenter
If .Range("I" & EmptyRow) = "" Or IsEmpty(.Range("I" & EmptyRow)) Then
.Range("I" & EmptyRow) = .Range("I" & EmptyRow)
Else
.Range("I" & EmptyRow) = RemoveFirstChar(.Range("I" & EmptyRow))
End If
.Range("G" & EmptyRow & ":M" & EmptyRow).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
.Range("K" & EmptyRow).Font.Bold = True
.Range("K" & EmptyRow).Font.Size = 12
EmptyRow = EmptyRow + 1
End If
End If
rstQ_PayrollLog.MoveNext
Loop
.Range("A" & EmptyRow - 1 & ":M" & EmptyRow - 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
'the below will sort the Payroll Log
.Range("A7:N" & EmptyRow - 1).Select
.ActiveSheet.Sort.SortFields.Clear
.ActiveSheet.Sort.SortFields.Add Key:=Range( _
"C8:C" & EmptyRow - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.ActiveSheet.Sort.SortFields.Add Key:=Range( _
"A8:A" & EmptyRow - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.ActiveSheet.Sort.SortFields.Add Key:=Range( _
"D8:D" & EmptyRow - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With .ActiveSheet.Sort
.SetRange Range("A7:N" & EmptyRow - 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Range("B6").Select
'this sets the Print Area so the TimecardID column will not print
.ActiveSheet.PageSetup.PrintArea = "$A$1:$M$" & EmptyRow - 1
End With
rstQ_PayrollLog.Close
Set rstQ_PayrollLog = Nothing
End Sub
Sub OpenPayrollLogExcelFile()
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Set varFile = Nothing
' Set up the File Dialog. '
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box '
.AllowMultiSelect = False
' Set the title of the dialog box. '
.Title = "Please select the Payroll Log file you wish to open."
' Clear out the current filters, and add our own.'
.Filters.Clear
.Filters.Add "Excel", "*.XLSX"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the '
' user picked at least one file. If the .Show method returns '
' False, the user clicked Cancel. '
If .Show = True Then
For Each varFile In .SelectedItems
FileToOpen = varFile
Next
Else
MsgBox "Operation cancelled."
Exit Sub
End If
End With
'this will actually open the Excel file
Set XL = CreateObject("Excel.Application")
Set WB = XL.Workbooks.Open(FileToOpen)
XL.Visible = True
End Sub
Public Function RemoveFirstChar(RemFstChar As String) As String
If Left(RemFstChar, 1) = "$" Then
RemFstChar = Replace(RemFstChar, "$", "")
End If
RemoveFirstChar = RemFstChar
End Function