Private Sub CopyExcel2Access(Byval sWorkBookName As String, _
                                                          Byval sTableSheet As _
                                                          String, _
                                                          Byval sDBName As _
                                                          String)
      Dim DB1 As Database
      Dim DB2 As Database
      Dim Rs1 As Recordset
      Dim Rs2 As Recordset
      Dim fld As Field
      Dim tble As TableDef
 
      'Access-DB öffnen und neue Tabelle anlegen:
      Set DB1 = DBEngine.OpenDatabase(sDBNAme, True, False)
      Set DB2 = DBEngine.OpenDatabase(sWorkBookName, False, False, "Excel 8.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.Typ, 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