ChatGPT isn't as good as it thinks it is! Need help with some code that isn't working.

[Canadian911Guy]

Ok, I made some revisions to the original NON-WORKING code I submitted. I changed things from late-binding to early-binding and I added a lot of Error Handling to try to find the problem—It didn't work.

So, here is the error:


Also, maybe some background on what I'm trying to do:



The Access Database tracks employee training and certifications. In the data are expiry dates for some records, but not all records. Then I export the Access Data to Excel into a sheet called “Raw Data” (but I can change that if needed) and into a table I named “MyTable”. The table has headers in Row #1. Then in the Excel sheet, I have two rows that calculate dates 30-Days and 90-Days before the Expiry Date that was part of the imported Access Data. Then I have VBA code in the Excel sheet that emails me anytime one of those dates triggers at 30- & 90-Day intervals and that is run on a monthly basis. The Excel VBA code works very well. So then as records are added, updated, removed from the Access database, the export to Excel should update the existing file with the new Access information. Whether that be deleting rows (records), updating fields (new expiry date), etc. That way, the Excel sheet should always match the Access database.

PS: The difference between the WORKING CODE and the NON-WORKING CODE is that the WORKING CODE does not make changes if the Access data has been changed, updated, or records deleted. The NON-WORKING CODE was my attempt to ensure those changes take place.

Please let me know if you need any clarification.

-Mark

WORKING CODE:

Function IsDateInCollection(ByVal searchDate As Date, ByVal searchCollection As Collection) As Boolean
    On Error Resume Next
    Dim item As Variant
    For Each item In searchCollection
        If CDate(item) = searchDate Then
            IsDateInCollection = True
            Exit Function
        End If
    Next item
    Err.Clear
End Function


Sub SendEmailWhenDateExceeded()
    On Error GoTo ErrorHandler
    
    ' Declare variables
    Dim OutApp As Object, OutMail As Object
    Dim rng90 As Range, rng30 As Range, cell As Range
    Dim rowData As Range
    Dim value1 As Variant, value7 As Variant, value9 As Variant, value10 As Variant


    ' Define the ranges for 90-day and 30-day alerts
    With ThisWorkbook.ActiveSheet
        Set rng90 = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
        Set rng30 = .Range("M2:M" & .Cells(.Rows.Count, "M").End(xlUp).Row)
    End With


    ' Check if there are any dates to process
    If rng90.Cells.Count = 1 And IsEmpty(rng90.Value) And rng30.Cells.Count = 1 And IsEmpty(rng30.Value) Then
        MsgBox "No data found in columns K, L, and M.", vbInformation
        Exit Sub
    End If


    Set OutApp = CreateObject("Outlook.Application")


' Loop for 90-day alert
For Each cell In rng90
    If IsDate(cell.Value) And cell.Value <= Date And IsEmpty(cell.Offset(0, 2).Value) Then
        Set rowData = cell.EntireRow


        ' Extract data
        value1 = rowData.Cells(1, 11).Value ' Column "Expiry Date"
        value7 = rowData.Cells(1, 5).Value ' Column "Training Course"
        value9 = rowData.Cells(1, 3).Value ' Column "Last Name"
        value10 = rowData.Cells(1, 2).Value ' Column "First Name"


        ' Create and send email
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = "mcoderre@centralutilities.ca"
            .Subject = "Reminder: 90 Day Alert"
            .Body = "This is a 90 Day Alert for:" & vbCrLf & _
                    "First Name: " & value10 & vbCrLf & _
                    "Last Name: " & value9 & vbCrLf & _
                    "Training Course: " & value7 & vbCrLf & _
                    "Expiry Date: " & Format(value1, "dd-mmm-yyyy")
            .Send
        End With
        Set OutMail = Nothing


        ' Mark the sent date to the "90-day Alert Sent Date" column
        cell.Offset(0, 2).Value = Date


        ' Delay for 1 second
        Application.Wait Now + TimeValue("0:00:01")
    End If
Next cell


' Loop for 30-day alert
For Each cell In rng30
    If IsDate(cell.Value) And cell.Value <= Date And IsEmpty(cell.Offset(0, 2).Value) Then
        Set rowData = cell.EntireRow


        ' Extract data
        value1 = rowData.Cells(1, 11).Value ' Column "Expiry Date"
        value7 = rowData.Cells(1, 5).Value ' Column "Training Course"
        value9 = rowData.Cells(1, 3).Value ' Column "Last Name"
        value10 = rowData.Cells(1, 2).Value ' Column "First Name"


        ' Create and send email
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = "mcoderre@centralutilities.ca"
            .Subject = "Reminder: 30 Day Alert"
            .Body = "This is a 30 Day Alert for:" & vbCrLf & _
                    "First Name: " & value10 & vbCrLf & _
                    "Last Name: " & value9 & vbCrLf & _
                    "Training Course: " & value7 & vbCrLf & _
                    "Expiry Date: " & Format(value1, "dd-mmm-yyyy")
            .Send
        End With
        Set OutMail = Nothing


        ' Mark the sent date to the "30-day Alert Sent Date" column
        cell.Offset(0, 2).Value = Date


        ' Delay for 1 second
        Application.Wait Now + TimeValue("0:00:01")
    End If
Next cell


    ' Clean up
    Set OutApp = Nothing
    Set rng90 = Nothing
    Set rng30 = Nothing
    Set cell = Nothing
    Set rowData = Nothing


    Exit Sub


ErrorHandler:
    MsgBox "An error occurred. Error number: " & Err.Number & ", Description: " & Err.Description, vbCritical
    Exit Sub
End Sub

NON-WORKING CODE:

Sub ExportTableToExcel()
    On Error GoTo ErrorHandler
    
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlTable As Excel.ListObject
    Dim sql As String
    Dim i As Long
    Dim path As String
    Dim namedRange As String
    
    ' Define the path to your existing workbook
    path = "C:\1TrainingDatabase\ETB.xlsm"
    
    ' Define the named range
    namedRange = "MyDynamicRange"
    
    ' Define your SQL statement to select the data from your Access table
    sql = "SELECT * FROM ETB"
    
    ' Open a recordset based on your SQL statement
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sql)
    
    ' Create a new instance of Excel
    Set xlApp = New Excel.Application
    
    ' Check if the workbook exists
    If Len(Dir(path)) = 0 Then
        ' Workbook does not exist, create a new one
        Set xlBook = xlApp.Workbooks.Add
        xlBook.SaveAs FileName:=path, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Else
        ' Workbook exists, open it
        Set xlBook = xlApp.Workbooks.Open(path)
    End If
    
    ' Use the "Raw Data" sheet in the workbook
    ' Change the sheet name as needed
    Set xlSheet = xlBook.Worksheets("Raw Data")
    
    ' Clear the entire worksheet (including headers)
    xlSheet.UsedRange.ClearContents
    
    ' Define the range for the table
    Dim tableRange As Range
    Set tableRange = xlSheet.Range("A1:R392") ' Update the range to match your table's range
    
    ' Convert the range to an Excel table
    Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, tableRange, , xlYes)
    xlTable.Name = "MyTable" ' Specify the name for the table
    
    ' Write data from the recordset to the table
    
    rs.MoveFirst
    
    Do Until rs.EOF
        Dim targetRow As Excel.ListRow
        Set targetRow = xlTable.ListRows.Add ' Add a new row to the table
        
        For i = 0 To rs.Fields.Count - 1
            Dim fieldValue As Variant
            fieldValue = rs.Fields(i).Value
            
            On Error Resume Next ' Temporarily disable error handling
            
            Select Case True
                Case IsNull(fieldValue)
                    targetRow.Range.Cells(1, i + 1).Value = ""
                Case IsDate(fieldValue)
                    targetRow.Range.Cells(1, i + 1).Value = CDate(fieldValue)
                    ' Apply desired date format to the target cell
                    targetRow.Range.Cells(1, i + 1).NumberFormat = "dd-mmm-yyyy" ' Change the format as per your preference
                Case TypeName(fieldValue) = "Boolean"
                    targetRow.Range.Cells(1, i + 1).Value = fieldValue
                Case Else
                    targetRow.Range.Cells(1, i + 1).Value2 = fieldValue
            End Select
            
            On Error GoTo 0 ' Reset error handling
        Next i
        
        rs.MoveNext
    Loop
    
    ' Save and close the workbook
    xlBook.Close SaveChanges:=True
    
    ' Quit Excel
    xlApp.Quit
    
    ' Clean up
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    Exit Sub ' Add this to make sure ErrorHandler is not executed after normal execution
    
ErrorHandler:
    ' Error handling block
    Debug.Print "An error has occurred: " & Err.Description
    Debug.Print "Error Source: " & Err.Source
    Debug.Print "Error Line: " & Erl
    MsgBox "An error has occurred: " & Err.Description, vbCritical, "Error"
    
    ' Clean up in case of error
    If Not rs Is Nothing Then
        If Not (rs.EOF And rs.BOF) Then ' Check if the recordset is open
            rs.Close
        End If
        Set rs = Nothing
    End If
    
    Set db = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    If Not xlApp Is Nothing Then
        xlApp.Quit
        Set xlApp = Nothing
    End If
    
    Exit Sub
End Sub

[Micron]

Just copy/paste your code in your post(s) but please use code tags (# button on posting toolbar) to maintain indentation and readability. I'll do that one time for you.
Not working is not helpful. It means what in your case? Not running? No result? Wrong results? Error messages? I didn't look yet to see if you id'd any errors by commenting your code.
Working

Sub ExportTableToExcel()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim sql As String
    Dim i As Integer
    Dim path As String
    Dim lastRow As Long
    Dim xlRow As Long
    Dim found As Boolean

    On Error GoTo ErrorHandler

    ' Define the path to your existing workbook
    path = "C:\Users\mcoderre\Documents\ETB.xlsm"
    
    ' Define your SQL statement to select the data from your Access table
    sql = "SELECT * FROM ETB"

    ' Open a recordset based on your SQL statement
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sql)

    ' Create a new instance of Excel
    Set xlApp = CreateObject("Excel.Application")

    ' Check if the workbook exists
    If Len(Dir(path)) = 0 Then
        ' Workbook does not exist, create a new one
        Set xlBook = xlApp.Workbooks.Add
        xlBook.SaveAs path
    Else
        ' Workbook exists, open it
        Set xlBook = xlApp.Workbooks.Open(path)
    End If

    ' Use the "Raw Data" sheet in the workbook
    ' Change the sheet name as needed
    Set xlSheet = xlBook.Worksheets("Raw Data")

    ' Find the last row in the worksheet that contains data
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(-4162).Row

    ' Loop through the recordset
    Do Until rs.EOF
        found = False
        
        ' Loop through the rows in Excel to find a matching record
        For xlRow = 2 To lastRow
            If xlSheet.Cells(xlRow, 1).Value = rs.Fields(0).Value Then
                ' Found a match, update the record
                For i = 1 To rs.Fields.Count - 1
                    ' Skip the "attached image" field
                    If rs.Fields(i).Type <> dbAttachment Then
                        If Not IsNull(rs.Fields(i).Value) Then
                            Dim fieldValue As Variant
                            fieldValue = rs.Fields(i).Value
                            
                            If IsDate(fieldValue) Then
                                ' Handle Date values
                                xlSheet.Cells(xlRow, i + 1).Value = CDate(fieldValue)
                            Else
                                ' Handle other data types
                                xlSheet.Cells(xlRow, i + 1).Value = fieldValue
                            End If
                        End If
                    End If
                Next
                found = True
                Exit For
            End If
        Next

        If Not found Then
            ' No match found, append the record
            lastRow = lastRow + 1 ' Increment lastRow by 1 before assigning new data
            For i = 0 To rs.Fields.Count - 1
                ' Skip the "attached image" field
                If rs.Fields(i).Type <> dbAttachment Then
                    If Not IsNull(rs.Fields(i).Value) Then
                        fieldValue = rs.Fields(i).Value
                        
                        If IsDate(fieldValue) Then
                            ' Handle Date values
                            xlSheet.Cells(lastRow, i + 1).Value = CDate(fieldValue)
                        Else
                            ' Handle other data types
                            xlSheet.Cells(lastRow, i + 1).Value = fieldValue
                        End If
                    End If
                End If
            Next
        End If

        rs.MoveNext
    Loop

' Save and close the workbook
xlApp.Interactive = False ' Set Interactive to False
xlBook.Close SaveChanges:=True

' Quit Excel
xlApp.Quit

' Clean up
rs.Close
Set rs = Nothing
Set db = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Interactive = True ' Set Interactive back to True
Set xlApp = Nothing

Exit Sub

ErrorHandler:
    ' Error handling block
    Debug.Print "An error has occurred: " & Err.Description
    Debug.Print "Error Source: " & Err.Source
    Debug.Print "Error Line: " & Erl
    Debug.Print "Field Name: " & rs.Fields(i).Name
    Debug.Print "Field Value: " & rs.Fields(i).Value
    MsgBox "An error has occurred: " & Err.Description, vbCritical, "Error"

    ' Clean up in case of error
    If Not rs Is Nothing Then
        If rs.EOF And rs.BOF Then ' rs is empty or not open
            rs.Close
        End If
        Set rs = Nothing
    End If

    Set db = Nothing
    Set xlSheet = Nothing

    If Not xlBook Is Nothing Then
        If xlBook.Saved = False Then xlBook.Close SaveChanges:=False
        Set xlBook = Nothing
    End If

    If Not xlApp Is Nothing Then
        xlApp.Interactive = False ' Set Interactive to False
        xlApp.Quit
        xlApp.Interactive = True ' Set Interactive back to True
        Set xlApp = Nothing
    End If

    Exit Sub
End Sub

Not Working

Sub ExportTableToExcel()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim sql As String
    Dim i As Integer
    Dim path As String
    Dim lastRow As Long
    Dim xlRow As Long
    Dim found As Boolean
    Dim deleteRows As Range ' Declare deleteRows as Range object
    Dim prevTrainingDate As Variant
    Dim prevExpiryDate As Variant

    On Error GoTo ErrorHandler

    ' Define the path to your existing workbook
    path = "C:\1TrainingDatabase\ETB.xlsm"

    ' Define your SQL statement to select the data from your Access table
    sql = "SELECT * FROM ETB"

    ' Open a recordset based on your SQL statement
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sql)

    ' Create a new instance of Excel
    Set xlApp = CreateObject("Excel.Application")

    ' Check if the workbook exists
    If Len(Dir(path)) = 0 Then
        ' Workbook does not exist, create a new one
        Set xlBook = xlApp.Workbooks.Add
        xlBook.SaveAs FileName:=path, FileFormat:=52
    Else
        ' Workbook exists, open it
        Set xlBook = xlApp.Workbooks.Open(path)
    End If

    ' Use the "Raw Data" sheet in the workbook
    ' Change the sheet name as needed
    Set xlSheet = xlBook.Worksheets("Raw Data")

    ' Find the last row in the worksheet that contains data
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(-4162).Row

    ' Loop through the rows in Excel to find any rows to be deleted
    For xlRow = 2 To lastRow
        found = False
        rs.MoveFirst
        Do Until rs.EOF
            If xlSheet.Cells(xlRow, 1).Value = rs.Fields(0).Value Then
                found = True
                Exit Do
            End If
            rs.MoveNext
        Loop
        
        ' If the row was not found in the Access data, add it to the deleteRows range
        If Not found Then
            If deleteRows Is Nothing Then
                Set deleteRows = xlSheet.Rows(xlRow)
            Else
                Set deleteRows = Union(deleteRows, xlSheet.Rows(xlRow))
            End If
        End If
    Next xlRow

    ' Delete the rows if there are any to be deleted
    If Not deleteRows Is Nothing Then
        deleteRows.Delete
    End If

    ' Loop through the recordset
    rs.MoveFirst
    Do Until rs.EOF
        found = False
        
        ' Loop through the rows in Excel to find a matching record
        For xlRow = 2 To lastRow
            If xlSheet.Cells(xlRow, 1).Value = rs.Fields(0).Value Then
                ' Found a match, update the record
                For i = 1 To rs.Fields.Count - 1
                    ' Find the previous Training Date and Course Expiry Date values for the current record
                    prevTrainingDate = xlSheet.Cells(xlRow, i).Value
                    prevExpiryDate = xlSheet.Cells(xlRow, 10).Value
                    
                    ' Update the Training Date if it has changed
                    If Not IsNull(prevTrainingDate) And Not IsNull(rs.Fields(i).Value) Then
                        If prevTrainingDate <> rs.Fields(i).Value Then
                            xlSheet.Cells(xlRow, i).Value = rs.Fields(i).Value
                        End If
                    End If

                    ' Update the Course Expiry Date if it has changed
                    If Not IsNull(prevExpiryDate) And Not IsNull(rs.Fields(10).Value) Then
                        If prevExpiryDate <> rs.Fields(10).Value Then
                            xlSheet.Cells(xlRow, 10).Value = rs.Fields(10).Value
                        End If
                    End If
                    
                    ' Skip the "attached image" field
                    If rs.Fields(i).Type <> dbAttachment Then
                        If Not IsNull(rs.Fields(i).Value) Then
                            Dim fieldValue As Variant
                            fieldValue = rs.Fields(i).Value
                            
                            If IsDate(fieldValue) Then
                                ' Handle Date values
                                xlSheet.Cells(xlRow, i + 1).Value = CDate(fieldValue)
                            Else
                                ' Handle other data types
                                xlSheet.Cells(xlRow, i + 1).Value = fieldValue
                            End If
                        End If
                    End If
                Next i ' Close the inner For loop
            End If
        Next xlRow ' Close the outer For loop

        If Not found Then
            ' No match found, append the record
            lastRow = lastRow + 1 ' Increment lastRow by 1 before assigning new data
            For i = 0 To rs.Fields.Count - 1
                ' Skip the "attached image" field
                If rs.Fields(i).Type <> dbAttachment Then
                    If Not IsNull(rs.Fields(i).Value) Then
                        fieldValue = rs.Fields(i).Value
                        
                        If IsDate(fieldValue) Then
                            ' Handle Date values
                            xlSheet.Cells(lastRow, i + 1).Value = CDate(fieldValue)
                        Else
                            ' Handle other data types
                            xlSheet.Cells(lastRow, i + 1).Value = fieldValue
                        End If
                    End If
                End If
            Next i ' Close the inner For loop
        End If

        rs.MoveNext
    Loop

    ' Save and close the workbook
    xlApp.Interactive = False ' Set Interactive to False
    xlBook.Close SaveChanges:=True

    ' Quit Excel
    xlApp.Quit

    ' Clean up
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    xlApp.Interactive = True ' Set Interactive back to True
    Set xlApp = Nothing

    Exit Sub

ErrorHandler:
    ' Error handling block
    Debug.Print "An error has occurred: " & Err.Description
    Debug.Print "Error Source: " & Err.Source
    Debug.Print "Error Line: " & Erl
    Debug.Print "Field Name: " & rs.Fields(i).Name
    Debug.Print "Field Value: " & rs.Fields(i).Value
    MsgBox "An error has occurred: " & Err.Description, vbCritical, "Error"

    ' Clean up in case of error
    If Not rs Is Nothing Then
        If rs.EOF And rs.BOF Then ' rs is empty or not open
            rs.Close
        End If
        Set rs = Nothing
    End If

    Set db = Nothing
    Set xlSheet = Nothing

' Delete the rows if there are any to be deleted
If Not deleteRows Is Nothing Then
    If deleteRows.Cells.Count > 1 Then ' Check if the range has more than one cell
        deleteRows.Delete
    Else
        deleteRows.EntireRow.Delete ' Delete the entire row if only one cell in the range
    End If
End If

Exit Sub
End Sub

[Micron]

I believe I do see one issue, being that if the wb doesn't exist, when you create it, it will contain one sheet named Sheet1? Then this should raise an error:
Set xlSheet = xlBook.Worksheets("Raw Data") because the wb contains no sheet by that name (as far as I can tell). Consider using dynamic named range, then delete the range, then write the rs to the named range. Simpler, I think, because you'll achieve automatic deletion of rows that are not in the rs.

[Canadian911Guy]

Thank you for the input. I updated my original post with additional information.

-Mark

[Micron]

I read your explanation but can't figure out why you'd use Excel at all for this. The only reason I would do what you seem to be doing is to avail myself of Excel's superior charts. If all you want to do is calculate due/overdue certs and/or send emails, you don't need Excel and by doing so, are only unnecessarily complicating things.

If you stated whether this was a compile error or a runtime error, I missed it in spite of looking. As for the error, 1004 is, IMO, the most useless error number ever. It must have 10 or even 20 causes. Anyway, why use value2? You might substitute Value2 with a hard coded value to test - just make sure the value is not a date or currency data type, because you can't use Value2 for those.

Haven't studied the code because of the above points but I wouldn't Dim a variable inside of a loop as you are (fieldValue). Also, I would move the cleanup stuff to just after a line label (e.g. exitHere ) then Exit Sub. If there's an error, msgbox if desired, then just Resume exitHere where the cleanup will take place.