Private Sub CreateMDB()
  ' Access-MDB erzeugen
  Dim sAppPath As String
  Dim F As Integer
  Dim nSize As Long
  Dim sLine As String
  Dim sData() As String
  Dim oDB As DAO.Database
  Dim oRs As DAO.Recordset
  Dim oTabDef As New DAO.TableDef
  Dim oField As New DAO.Field
 
  ' MDB erstellen
  'Abfragen, ob DAtei schon besteht
  If Not FileExists(PfadDB) Then
 
  Set oDB = DBEngine.CreateDatabase(PfadDB, dbLangGeneral, dbVersion30)
 
  ' Tabelle erstellen
  With oTabDef
    .Name = "Liste"
 
    ' DatenoField #1
    oField.Name = "Nr"
    oField.Type = dbLong
    oField.Attributes = dbAutoIncrField
    .Fields.Append oField
    Set oField = Nothing
 
    ' DatenoField #2
    oField.Name = "Überschrift4"
    oField.Type = dbText
    oField.Size = 10
    oField.AllowZeroLength = True
    .Fields.Append oField
    Set oField = Nothing
 
    ' DatenoField #2
    oField.Name = "Überschrift4"
    oField.Type = dbText
    oField.Size = 25
    oField.AllowZeroLength = True
    .Fields.Append oField
    Set oField = Nothing
 
    ' DatenoField #3
    oField.Name = "Überschrift4"
    oField.Type = dbText
    oField.Size = 50
    oField.AllowZeroLength = True
    .Fields.Append oField
    Set oField = Nothing
 
 
    ' DatenoField #4
    oField.Name = "Überschrift4"
    oField.Type = dbText 'boolean
    oField.Size = 50
    oField.AllowZeroLength = True
    .Fields.Append oField
    Set oField = Nothing
 
 
    oDB.TableDefs.Append oTabDef
  End With
 
  Else 'DB vorhanden
    'vorhandene DB öffenen
    Set oDB = DBEngine.OpenDatabase(PfadDB)
  End If 'wenn filexists wahr
  ' Recordset erstellen
  Set oRs = oDB.OpenRecordset("Liste")
 
  ' Datendatei auslesen und Datensätze schreiben
  Dim ix As Integer
  Dim iy As Integer
  '################
  'Excel öffnen
    Dim strPath2 As String
    strPath2 = Import_Path
    Dim ExcelApp As Object
    Set ExcelApp = CreateObject("Excel.Application")
    With ExcelApp   'Zum Aufrufen einer vorhandenen Datei, Pfadname liegt in 
    ' Var. StrPath
        '.Visible = True
        .workbooks.Open FileName:=strPath2
    End With
 
  '###############
    ix = 2
    Do Until ExcelApp.activesheet.Cells(ix, 1) = ""
        ix = ix + 1
    Loop
 
    'MsgBox ix
    With ProgressBar1
        .Max = ix
        .Min = 0
        .Value = 0
        .visible = True
    End With
 
    ' Datendatei auslesen und Datensätze schreiben
 
    Dim zCounter As Integer
    Dim VariableX As String
    zCounter = 2    'Zahlenwert; größer 0
    'durchsucht die Zeilen mithilfe einer Schleife, auf die erste leere Zelle
    Do Until ExcelApp.activesheet.Cells(zCounter, 1) = ""
         'ExcelApp.activesheet.Cells(zCounter, 14).Value
 
      Grid1.MoveLast
      zaehler = Grid1.Row
 
      oRs.AddNew
      oRs.Fields("Nr").Value = zCounter - 1
      oRs.Fields("Überschrift1").Value = ExcelApp.activesheet.Cells(zCounter, _
        1).Value
      oRs.Fields("Überschrift2").Value = ExcelApp.activesheet.Cells(zCounter, _
      2).Value
      oRs.Fields("Überschrift3").Value = ExcelApp.activesheet.Cells(zCounter, _
      3).Value
      oRs.Fields("Überschrift4").Value = ExcelApp.activesheet.Cells(zCounter, _
      4).Value
 
      oRs.Update
    'End If
 
weiter:
    ' Status anzeigen
    DoEvents 'möglichkeit zum bsp. abbruch geben
    ' ProgressBar anzeigen
    'iy = iy + 1
    ProgressBar1.Value = zCounter
 
        zCounter = zCounter + 1
  Loop
 
  'nummerierung
 
  'Excel schliessen
    With ExcelApp
                '.workbooks.Save
                '.activesheet.Columns("A:S").autofit
                '.workbooks(1).Save
                .workbooks.Close                'Schließt die Arbeitsmappe; 
                ' deren Name ja schon vorhanden ist
                '.DisplayAlerts = True   'Zulassen von Fehlermeldungen; nur bei _
                  Saveas
                .visible = True
                .quit   'Beendet Excel wieder
    End With
    '----------------
  ' Datenbank schließen
  oRs.Close
  oDB.Close
  Set oRs = Nothing
  Set oDB = Nothing
End Sub