Use VBA excel to delete records in access table that match a named range in excel

Option Explicit

Sub DB_Insert_via_ADOSQL()
'Author       : Ken Puls 
'Macro purpose: To add record to Access database using ADO and SQL
'NOTE:  Reference to Microsoft ActiveX Data Objects Libary required

    Dim cnt As New ADODB.Connection, _
            rst As New ADODB.Recordset, _
            dbPath As String, _
            tblName As String, _
            rngColHeads As Range, _
            rngTblRcds As Range, _
            colHead As String, _
            rcdDetail As String, _
            ch As Integer, _
            cl As Integer, _
            notNull As Boolean

    Blad12.Activate
    'Set the string to the path of your database as defined on the worksheet
    dbPath = "Y:\labels\labels gekoppeld aan database voor etiketeermachine\Databestanden\Database bestand Access\Backend\productieplanning DB.accdb"
    tblName = "productieplanning"
    Set rngColHeads = ActiveSheet.Range("tblHeadings")
    Set rngTblRcds = ActiveSheet.Range("tblRecords")

    'Concatenate a string with the names of the column headings
    colHead = " ("
    For ch = 1 To rngColHeads.Count
        colHead = colHead & rngColHeads.Columns(ch).Value
        Select Case ch
            Case Is = rngColHeads.Count
                colHead = colHead & ")"
            Case Else
                colHead = colHead & ","
        End Select
    Next ch

    'Open connection to the database
    cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & dbPath & ";"

    'Begin transaction processing
    On Error GoTo EndUpdate
    cnt.BeginTrans

    'Insert records into database from worksheet table
    For cl = 1 To rngTblRcds.Rows.Count

        'Assume record is completely Null, and open record string for concatenation
        notNull = False
        rcdDetail = "('"

        'Evaluate field in the record
        For ch = 1 To rngColHeads.Count
            Select Case rngTblRcds.Rows(cl).Columns(ch).Value
                    'if empty, append value of null to string
                Case Is = Empty
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL)"
                        Case Else
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL,'"
                    End Select

                    'if not empty, set notNull to true, and append value to string
                Case Else
                    notNull = True
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "')"
                        Case Else
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "','"
                    End Select
            End Select
        Next ch

        'If record consists of only Null values, do not insert it to table, otherwise
        'insert the record
        Select Case notNull
            Case Is = True
                rst.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, cnt
            Case Is = False
                'do not insert record
        End Select
    Next cl

EndUpdate:
    'Check if error was encounted
    If Err.Number <> 0 Then
        'Error encountered.  Rollback transaction and inform user
        On Error Resume Next
        cnt.RollbackTrans
        MsgBox "Er is iets misgegaan  Database niet bijgewerkt! controleer of er nergens geen ### staan, dit eerst oplossen", vbCritical, "Error!"
    Else
        On Error Resume Next
        cnt.CommitTrans
    End If

    'Close the ADO objects
    cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
    On Error GoTo 0
    
        'database wordt geopend, zit autorun macro in die de dubbele waarde verwijderd.
        With GetObject("Y:\labels\labels gekoppeld aan database voor etiketeermachine\Databestanden\Database bestand Access\Backend\productieplanning DB.accdb")
     
         End With
  
Blad11.Activate

End Sub

    'Begin transaction processing
    On Error GoTo EndUpdate
    cnt.BeginTrans

cnt.Execute sSQL

cnt.Execute "DELETE * FROM " & tblName & " WHERE DateColumn = #" & worksheets("x").range("DeleteDate") & "#"