Ok, so I've got a database I've built for tracking our companies training and certifications.I've written some VBA code to export the data to Excel, update the cells in Excel if the fields in Access changed, and remove any data (rows) that have been deleted from the Access Database since the last run of the code.Now, the "deleting" and “updating” of cells/rows in Excel via the VBA code is a new addition to what was working code previously.I have attached both the working version of the code and the non-working version.Could somebody look at this and help me out, please? ChatGPT, while helpful at times, has been messing this up lately.Thanks,-Mark
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.
Please let me know if you need any clarification.
-Mark
WORKING CODE
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
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
