Daten von Excel nach Acces exportieren VBA

[Enclave]

Hallo zusammen,
Chat GPT bringt mich leider nicht zum Ziel.


Ich habe eine excel Datei: c_lick_This.xlsm
mit dem Blatt: Auswertung
dort liegt eine Tabelle: OCC_Auswertung
mit ca 150-300 Zeilen und 79 Spalten
ich möchte die Werte in eine Acces Datenbank einfügen.
Acces: Datenbank_Gesamt.accdb
Tabelle: tbl_OCC_Voice
mit 79 Spalten


Name und Reihnfolge ist 1:1

Ziel des Makro:
suche den Bereich in der Tabelle in Excel wo Daten stehen, kopiere sie und füge sie in Acces ein.

Excel und Acces liegen nicht im selben Ordner so das ich einen Pfad eingeben muss um zu bestimmen wo sie sind.

Bitte um Hilfe

ChatGpt hat nach 4h mir unteranderem folgenden Code geben:

Code:

Sub ImportDataToAccess()
    ' Deklarieren der Variablen
    Dim excelFilePath As String
    Dim accessFilePath As String
    Dim excelSheetName As String
    Dim tableName As String
    Dim conn As Object
    Dim ws As Worksheet
    Dim r As Long
    Dim sql As String
    Dim lastRow As Long
    Dim fieldArray As Variant
    Dim i As Integer
    Dim value As String

    ' Pfade und Namen festlegen
    excelFilePath = "R:\###\CustomerServiceManagement\KC_CSM\WFM\fLink\c_lick_This.xlsm"
    accessFilePath = "R:\###\CustomerServiceManagement\KC_CSM\WFM\fLink\Datenbank_Gesamt.accdb"
    excelSheetName = "Auswertung"
    tableName = "tbl_OCC_Voice"

    ' Verbindung zu Access herstellen
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFilePath

    ' Aktuelles Workbook und Worksheet setzen
    Set ws = ThisWorkbook.Sheets(excelSheetName)

    ' Bestimmen der letzten genutzten Zeile in der Excel-Tabelle
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Felder definieren
    fieldArray = Array("tblDatum", "tblSkillID", "tblSkillName", _
                       "tblAnwahl0", "tblAnwahl1", "tblAnwahl2", "tblAnwahl3", "tblAnwahl4", _
                       "tblAnwahl5", "tblAnwahl6", "tblAnwahl7", "tblAnwahl8", "tblAnwahl9", _
                       "tblAnwahl10", "tblAnwahl11", "tblAnwahl12", "tblAnwahl13", "tblAnwahl14", _
                       "tblAnwahl15", "tblAnwahl16", "tblAnwahl17", "tblAnwahl18", "tblAnwahl19", _
                       "tblAnwahl20", "tblAnwahl21", "tblAnwahl22", "tblAnwahl23", "tblAnwahlGesamt", _
                       "tblAnnahme0", "tblAnnahme1", "tblAnnahme2", "tblAnnahme3", "tblAnnahme4", _
                       "tblAnnahme5", "tblAnnahme6", "tblAnnahme7", "tblAnnahme8", "tblAnnahme9", _
                       "tblAnnahme10", "tblAnnahme11", "tblAnnahme12", "tblAnnahme13", "tblAnnahme14", _
                       "tblAnnahme15", "tblAnnahme16", "tblAnnahme17", "tblAnnahme18", "tblAnnahme19", _
                       "tblAnnahme20", "tblAnnahme21", "tblAnnahme22", "tblAnnahme23", "tblAnnahmeGesamt", _
                       "tblAHT0", "tblAHT1", "tblAHT2", "tblAHT3", "tblAHT4", "tblAHT5", "tblAHT6", _
                       "tblAHT7", "tblAHT8", "tblAHT9", "tblAHT10", "tblAHT11", "tblAHT12", "tblAHT13", _
                       "tblAHT14", "tblAHT15", "tblAHT16", "tblAHT17", "tblAHT18", "tblAHT19", "tblAHT20", _
                       "tblAHT21", "tblAHT22", "tblAHT23", "tblAHTGesamt", "tblAATGesamt")

    ' SQL Insert-Befehl für jede Zeile in der Excel-Tabelle
    For r = 3 To lastRow
        sql = "INSERT INTO " & tableName & " ("

        ' Feldnamen hinzufügen
        For i = 0 To UBound(fieldArray)
            If i > 0 Then
                sql = sql & ", "
            End If
            sql = sql & "[" & fieldArray(i) & "]"
        Next i

        sql = sql & ") VALUES ("

        ' Werte hinzufügen
        For i = 0 To UBound(fieldArray)
            If i > 0 Then
                sql = sql & ", "
            End If
            value = ws.Cells(r, i + 1).Value
            ' Werte korrekt formatieren
            If IsNumeric(value) Then
                sql = sql & value
            ElseIf IsDate(value) Then
                sql = sql & "#" & Format(ws.Cells(r, i + 1).Value, "yyyy-mm-dd") & "#"
            Else
                sql = sql & "'" & Replace(value, "'", "''") & "'"
            End If
        Next i

        sql = sql & ")"

        ' Debug-Druck des SQL-Befehls
        Debug.Print sql

        ' Ausführen des SQL-Befehls
        On Error GoTo ErrorHandler
        conn.Execute sql
    Next r

    ' Verbindung schließen
    conn.Close
    Set conn = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "Fehler beim Ausführen des SQL-Befehls: " & Err.Description
    conn.Close
    Set conn = Nothing
    Exit Sub
End Sub

[Warkings]

Mein Vorschlag wäre

Code:

Option Explicit

Private Function GetExcelConnection(ByVal xlFile As String, _
    Optional ByVal Headers As Boolean = True) As Connection
   
    Dim cn As New ADODB.Connection
   
    With cn
        .Provider = "Microsoft.ACE.OLEDB.16.0"
        '.ConnectionString = "Data Source=" & xlFIle & "; Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
        .ConnectionString = "Data Source=" & xlFile & _
            "; Extended Properties=""Excel 12.0 Xml;HDR=" & _
            IIf(Headers, "YES", "NO") & """" & ";"

        .Open
    End With
   
    Set GetExcelConnection = cn
End Function


Sub writeIntoAccessDB()
   
    Const dbFile = "<Vollständiger Pfad zur Access Datenbank>"

    Dim xlCn As ADODB.Connection
    Dim sSQL As String
   
    Dim xlFile As String
    xlFile = "<Vollständiger Pfad zur Excel Datei>"
   
    Set xlCn = GetExcelConnection(xlFile, True)
    sSQL = "SELECT * FROM [Tabelle2$];"
   
    sSQL = "INSERT INTO xlData in '" & dbFile & "'" & sSQL
    xlCn.Execute sSQL

End Sub

Du musst eine Referenz zu ADO einfügen.

[Enclave]

Hey ich hab den Code mal rüber kopiert und bekomme dabei einen Fehler:
Benutzerdefinierter Typ nicht definiert.

Ich weiß nicht was ADO ist, aber wenn ich dafür eine Erweiterung brauche geht das nicht da ich nichts installieren kann.

mit folgendem Code hab ich endlich Daten in die DB bekommen

Code:

Sub CopyPasteToAccess()
    ' Variablen deklarieren
    Dim excelFilePath As String
    Dim accessFilePath As String
    Dim excelSheetName As String
    Dim tableName As String
    Dim conn As Object
    Dim rs As Object
    Dim ws As Worksheet
    Dim r As Long
    Dim lastRow As Long
    Dim value As Variant
    Dim skillID As Long
    Dim datum As String
    Dim skillName As String
    Dim checkRS As Object
    Dim sqlCheck As String
   
    ' Pfade und Namen festlegen
    excelFilePath = "R:\###\CustomerServiceManagement\KC_CSM\WFM\fLink\c_lick_This.xlsm"
    accessFilePath = "R:\###\CustomerServiceManagement\KC_CSM\WFM\fLink\Datenbank_Gesamt.accdb"
    excelSheetName = "Auswertung"
    tableName = "tbl_OCC_Voice"
   
    ' Verbindung zu Access herstellen
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFilePath
   
    ' Recordset erstellen
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open tableName, conn, 1, 3
   
    ' Aktuelles Workbook und Worksheet setzen
    Set ws = ThisWorkbook.Sheets(excelSheetName)
   
    ' Bestimmen der letzten genutzten Zeile in der Excel-Tabelle
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
   
    ' Daten in Recordset kopieren
    For r = 3 To lastRow
        ' Überprüfen, ob die Zelle in Spalte A ein Datum enthält
        If IsDate(ws.Cells(r, 1).Value) Then
            datum = Format(ws.Cells(r, 1).Value, "yyyy-mm-dd")
            skillID = CLng(ws.Cells(r, 2).Value)
            skillName = ws.Cells(r, 3).Value
           
            ' Prüfen, ob der Datensatz bereits existiert
            sqlCheck = "SELECT COUNT(*) AS RecordCount FROM " & tableName & " WHERE tblDatum = #" & datum & "# AND tblSkillID = " & skillID
            Set checkRS = conn.Execute(sqlCheck)
           
            If checkRS("RecordCount") > 0 Then
                MsgBox "Datensatz existiert bereits: Datum=" & datum & ", SkillID=" & skillID & ", SkillName=" & skillName, vbExclamation
                checkRS.Close
                Set checkRS = Nothing
                GoTo Cleanup
            End If
           
            checkRS.Close
            Set checkRS = Nothing
           
            ' Neuen Datensatz hinzufügen
            rs.AddNew
            rs.Fields("tblDatum").Value = datum
            rs.Fields("tblSkillID").Value = skillID
            rs.Fields("tblSkillName").Value = skillName
           
            ' Restliche Felder dynamisch zuweisen
            For c = 4 To 79
                value = ws.Cells(r, c).Value
               
                ' Überprüfen des Feldtyps und entsprechend zuweisen
                Select Case rs.Fields(c - 1).Type
                    Case 2, 3, 4, 5 ' Numerische Typen
                        If IsNumeric(value) Then
                            rs.Fields(c - 1).Value = CLng(value)
                        Else
                            rs.Fields(c - 1).Value = 0 ' Standardwert bei nicht numerisch
                        End If
                    Case 7, 133, 134, 135 ' Datums-/Zeittypen
                        If IsDate(value) Then
                            rs.Fields(c - 1).Value = CDate(value)
                        Else
                            rs.Fields(c - 1).Value = Null ' Standardwert bei nicht Datum/Zeit
                        End If
                    Case Else ' Andere Typen (Text, Memo, etc.)
                        rs.Fields(c - 1).Value = CStr(value)
                End Select
            Next c
           
            rs.Update
        End If
    Next r
   
Cleanup:
    ' Verbindung schließen
    rs.Close
    Set rs = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "Fehler beim Ausführen des SQL-Befehls: " & Err.Description
    rs.Close
    Set rs = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
End Sub

[Ralf A]

Hi,

wenn Du sowieso in Acces weiterarbeiten willst, weshalb importierst Du die Daten von da aus nicht aus Excel heraus?

[Warkings]

Set conn = CreateObject("ADODB.Connection")

Wenn das funktioniert, heisst dass: Du hast ADO!!

Aber egal, noch weiter viel Erfolg.

[Enclave]

Ich will danach nicht mit Acces weiterarbeiten, ich lege dort die Daten nur ab, erstelle Berichte und will diese dann mit einer anderen Excel Datei abrufen

[snb]

z.B.

Code:

Sub M_snb_Excel_importeren_in_Access()
    With GetObject("G:\Access\fiets.mdb")
      .DoCmd.TransferSpreadsheet 0, 9, "import_snb", thisworkbook.fullname, -1
      .CloseCurrentDatabase
    End With
End Sub

P.S warum in Access speichern was auch in Excel gespeichert werden kann ??

[Enclave]

weil die Datenmenge zu groß wird.
es sind täglich ca 150 Zeilen und das gerne über eine Ganzeweile.

Da finde ich den Weg das über Acces als Datenbank besser

[Ralf A]

weil die Datenmenge zu groß wird.
es sind täglich ca 150 Zeilen und das gerne über eine Ganzeweile.

...schmunzel... nichts gegen Datenbanken. Kommt halt immer auf den Anwendungszweck an. Aber bei täglich 150 Zeilen kommst Du mit Excel pro Tabellenblatt ca. 18 Jahre aus. 
Und wenn Du in der anderen Excel-Zieldatei, mit der Du diese Daten abrufen willst, die Daten mit PQ nur in das Datenmodell lädst, dann kannst Du sogar zig-Millionen Datensätze speichern und verarbeiten ohne das Limit bis zu Deinem Renteneintrittsalter und darüber hinaus zu erreichen... Allein der Speicherplatz ist also kein triftiges Argument.
Auch ist es egal, ob Du mit Access weiterarbeiten willst oder nicht. Dein Ziel ist es ja, die Daten von Excel nach Access zu beamen. Da ist der Weg egal. Import, Export, das spielt keine Rolle wie die Daten da reinkommen. Kann man sich aber beides sparen...
Statt PQ in Excel kannst Du auch das kostenlose Tool Power BI nutzen. Das ist noch etwas mächtiger von der Funktionalität her. Mit beiden lassen sich, auch ohne Umweg über Access, zielgerichtete Berichte erstellen.