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:
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:
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