Private DB1 As Database
Private DB2 As Database
Private Rs1 As Recordset
Private Rs2 As Recordset
 
Private Const sDBNAME As String = "Pfad_und_Namen_der_Datenbank"
 
Private Sub Auto_Open()
    Dim myCmdBar As CommandBar
    Dim myButton As CommandBarButton
 
    Set myCmdBar = Application.CommandBars.Add(Name:="Excel2Access", _
      Temporary:=True)
    Set myButton = myCmdBar.Controls.Add(msoControlButton)
 
    With myButton
        .BuiltInFace = True
        .Style = msoButtonIconAndCaption
        .TooltipText = "Konvertiert die Tabelle in eine Access Tabelle"
        .FaceId = 548
        .OnAction = "CopyExcel2Access"
        .Visible = True
    End With
 
    myCmdBar.Visible = True
 
End Sub
 
'Excel-Tabelle in Access-Datenbank kopieren
Private Sub CopyExcel2Access()
 
  Dim DB1 As Database
  Dim DB2 As Database
  Dim Rs1 As Recordset
  Dim Rs2 As Recordset
  Dim fld As Field
  Dim tble As TableDef
  Dim sWorkBookName As String
  Dim sTableSheet As String
 
  sWorkBookName = ActiveWorkbook.Name
  sTableSheet = ActiveSheet.Name
 
  ' Access-DB öffnen und neue Tabelle anlegen:
  Set DB1 = DBEngine.OpenDatabase(sDBNAME, True, False)
  Set DB2 = DBEngine.OpenDatabase(sWorkBookName, False, False, "Excel 9.0;")
  Set Rs2 = DB2.OpenRecordset(sTableSheet & "$", dbOpenDynaset)
  Set tble = DB1.CreateTableDef("Kopie")
 
  With tble
    For Each fld In Rs2.Fields
      .Fields.Append .CreateField(fld.Name, fld.Type, fld.Size)
    Next
  End With
  DB1.TableDefs.Append tble
 
  ' Tabellen zeilenweise kopieren:
  Set Rs1 = DB1.OpenRecordset("Kopie", dbOpenDynaset)
  Do While Not Rs2.EOF
    With Rs1
      .AddNew
      For Each fld In Rs2.Fields
        .Fields(fld.Name).Value = fld.Value
      Next
      .Update
    End With
    Rs2.MoveNext
  Loop
 
  DB1.Close
  DB2.Close
End Sub