Option Explicit
Public CnA As New ADODB.Connection
 
Dim rsDatenUebertragen As ADODB.Recordset
 
Function openTable(ByRef rstTable As ADODB.Recordset, tableName As String)
    If CnA = "" Then
        ConnectionOpen
    End If
 
    Set rstTable = New ADODB.Recordset
    rstTable.CursorType = adOpenKeyset
    rstTable.CursorLocation = adUseClient
    rstTable.LockType = adLockOptimistic
 
    rstTable.Open tableName, CnA, adOpenKeyset, adLockOptimistic
End Function
Public Function ConnectionOpen() As Boolean
   Dim Msg As String
 
      On Error GoTo ConnectionError
      ConnectionOpen = True
      With CnA
         If CnA.State = adStateOpen Then
            'Connection bereits vorhanden
            Exit Function
         End If
         'Steuerung über Client
         .CursorLocation = adUseClient
         .Mode = adModeShareDenyNone
         'Zugriff auf Access 2000/97
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         'Zugriff auf MDB
         .ConnectionString = "####\DatenUebertragen.mdb"
         .Open
      End With
      Exit Function
 
ConnectionError:
      ConnectionOpen = False
      Msg = "Fehler bei Aufbau der Verbindung zur Datenbank: " & vbCrLf & _
             "Data Source=C:\Documents and" & _
             "Settings\Administrator\Desktop\DatenUebertragen.mdb" & vbCrLf & _
             vbCrLf & _
            "Fehler: " & Err.Number & vbCrLf & _
            Err.Description
      MsgBox Msg, , "Fehler Connection"
End Function
 
Sub datenUebertragen()
    openTable rsDatenUebertragen, "Select * from DBDatenUebertragen"
    Dim sql As String
    sql = "SELECT * From DBDatenUebertragen"
    openTable rsDatenUebertragen, sql
    rsDatenUebertragen.AddNew
    rsDatenUebertragen!Field = Selection
    rsDatenUebertragen.Update
    rsDatenUebertragen.Close
 
End Sub

Gruss Michael