Code:
Sub AddRecordsIntoAccessTable()
'-----------------------------------------------------------------------------
'The macro opens the Sample.accdb database and adds the 7 rows from the sheet
'"Excel Data" in the "Customers" table of the database.
'The code uses late binding, so no reference to external library is required.
'Written By: Christos Samaras
'Date: 27/06/2020
'E-mail: xristos.samaras@gmail.com
'Site: https://myengineeringworld.net
'-----------------------------------------------------------------------------
'Declaring the necessary variables.
Dim accessFile As String
Dim accessTable As String
Dim sht As Worksheet
Dim lastRow As Long
Dim lastColumn As Integer
Dim con As Object
Dim rs As Object
Dim sql As String
Dim sql1 As String
Dim i As Long
Dim j As Integer
Dim strSheetName As String
strSheetName = ActiveSheet.Name
'Disable the screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file. You can also use the full path of the file like this:
'AccessFile = "C:\Users\Christos\Desktop\Sample.accdb"
accessFile = ThisWorkbook.Path & "\" & "Sample.accdb"
'Ensure that the Access file exists.
If FileExists(accessFile) = False Then
MsgBox "The Access file doesn't exist!", vbCritical, "Invalid Access file path"
Exit Sub
End If
MsgBox ("Variable = " & strSheetName)
'Set the name of the table you want to add the data.
accessTable = strSheetName
'Set the worksheet that contains the data.
On Error Resume Next
Set sht = ThisWorkbook.ActiveSheet
'ThisWorkbook.Sheets("Excel Data")
If Err.Number <> 0 Then
MsgBox "The given worksheet does not exist!", vbExclamation, "Invalid Sheet Name"
Exit Sub
End If
Err.Clear
'Find the last row and last column in the given worksheet.
With sht
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Check if there are data in the worksheet.
If lastRow < 2 Or lastColumn < 1 Then
MsgBox "There are no data in the given worksheet!", vbCritical, "Empty Data"
Exit Sub
End If
'Create the ADODB connection object.
Set con = CreateObject("ADODB.connection")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "The connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
Err.Clear
'Open the connection.
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFile
con.Execute "DELETE * FROM " & accessTable
sql = "SELECT * FROM " & accessTable
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Check if the object was created.
' If Err.Number <> 0 Then
' Set rs = Nothing
' Set con = Nothing
' MsgBox "The recordset was not created!", vbCritical, "Recordset Error"
' Exit Sub
' End If
' Err.Clear
con.Execute "DELETE * FROM " & accessTable
'Set the necessary recordset properties.
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
'Open the recordset.
rs.Open sql, con
con.Execute "DELETE * FROM " & accessTable
'Add the records from Excel to Access by looping through the rows and columns of the given worksheet.
'Here the headers are in the row 1 and they are identical to the Access table headers.
'This is the reason why, for example, there are no spaces in the headers of the sample worksheet.
For i = 2 To lastRow
rs.AddNew
For j = 1 To lastColumn
'This is how it will look like the first time (i = 2, j = 1):
'rs("FirstName") = "Bob"
rs(sht.Cells(1, j).Value) = sht.Cells(i, j).Value
Next j
rs.Update
Next i
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Re-enable the screen.
Application.ScreenUpdating = True
'Inform the user that the macro was executed successfully.
MsgBox lastRow - 1 & " rows were successfully added into the '" & accessTable & "' table!", vbInformation, "Done"
End Sub
Function FileExists(FilePath As String) As Boolean
'--------------------------------------------------
'Checks if a file exists (using the Dir function).
'--------------------------------------------------
On Error Resume Next
If Len(FilePath) > 0 Then
If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
End If
On Error GoTo 0
End Function
Deleting Accees Table Records from Excel VBA
Windows 11 
Access 2019
Reply With Quote
Originally Posted by jimrosser
