Private Function CopyExclTab(Byval sTabName As String, _
                                                       Byval sWorkbookPfad As _
                                                       String, _
                                                       Byval sAccessBase As _
                                                       String) As Boolean
 
       Dim DBQuell As DataBase
       Dim RsQuell As RecordSet
       Dim DBZiel As Database
       Dim RsZiel As Recordset
       Dim tbl As TableDef
       Dim tblExist As Boolean
       Dim fld As Field
 
       tblExist = False
       CopyExclTab = False
 
       On Error Resume Next
       If Dir(sAccessBase) = "" Then 
              MsgBox "Access-Datenbank nicht gefunden",vbExclamation,"Fehler:"
              Exit Sub
       End If
 
       If Dir(sWorkbookPfad) = "" Then 
              MsgBox "Excel-Workbook nicht gefunden",vbExclamation,"Fehler:"
              Exit Sub
       End If
 
       'Access DB im exclusiv Modus öffnen ....
       Set DBZiel = DBEngine.OpenDataBase(sAccessBase, True, False,";pwd=")
 
       Set DBQuell = DBEngine.OpenDataBase(sWorkBookPfad, False, False, "Excel" & _
         "8.0;")
        Set  RsQuell = DBQuell.OpenRecordset(sTabName+"$", dbOpenDynaset) 
        If Err.Number <> 0 Then 
             MsgBox "Die angegebene Tabelle existiert" & _
               "nicht.",vbExclamation,"Fehler"
             Exit Sub
        End If
 
        'Alle Tabelle durchlaufen, ob die Tabelle schon vorhanden ist ....
       For Each tbl In DBZiel.TableDefs
             If Ucase(tbl.Name) = Ucase(sTabName) Then
                    tblExist=True
                    Exit For
             End If
        Next
 
        ' Fall: die Tabelle ist in der AccessDB noch nicht existent, dann Eine 
        ' erzeugen
        If Not tblExist Then
              Set tbl=DBZiel.CreateTableDefs(sTabName)
              With tbl
                   For Each fld In RsQuell.Fields
                         .Fields.Append .CreateField(fld.Name,fld.Typ,fld.Size)
                   Next
              End With
              DBZiel.TableDefs.Append tbl
        End If 
 
        'Zieltabelle öffnen
        Set RsZiel = DBZiel.OpenRecordset(sTabName, dbOpenDynaset)
 
        '1:1 kopieren
        If RsQuell.EOF Then
             CopyExlTab = True
             Exit Sub
        End If
 
         Do While Not RsQuell.EOF
                RsZiel.AddNew
                For Each fld In RsQuell
                      RsZiel.Fields(fld.Name).Value = fld.Value
                Next
                RsZiel.UpDate
                RsQuell.MoveNext
         Loop 
 
         CopyExclTab = True
End Function