Public Sub subImport()
On Error GoTo Fehler
Const c_strProvider As String = "Microsoft.Jet.OLEDB.4.0;"
Const c_strQuellDB As String = "C:\...\db2.mdb"
Const c_strUserID As String = "Admin"
Const c_strQuellTBL As String = "Tabelle2"
Const c_strSenkeTBL As String = "Tabelle1"
Dim cnnQuelle As ADODB.Connection
Dim rsQuelle As ADODB.Recordset
Dim strSQL As String
Dim cnnSenke As ADODB.Connection
Dim rsSenke As ADODB.Recordset
strSQL = "SELECT ID, Anzahl FROM " & c_strQuellTBL
Set cnnQuelle = New ADODB.Connection
cnnQuelle.Provider = c_strProvider
cnnQuelle.Open c_strQuellDB, c_strUserID
Set rsQuelle = cnnQuelle.Execute(strSQL, Options:=adCmdText)
If Not rsQuelle.BOF Then
Set cnnSenke = CurrentProject.Connection
Set rsSenke = New ADODB.Recordset
With rsSenke
.ActiveConnection = cnnSenke
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open c_strSenkeTBL, Options:=adCmdTableDirect
End With
If rsSenke.Supports(adUpdateBatch) Then
rsQuelle.MoveFirst
Do While Not rsQuelle.EOF
With rsSenke
.AddNew
.Fields("ID").Value = rsQuelle.Fields("ID").Value
.Fields("Anzahl").Value = rsQuelle.Fields("Anzahl").Value
End With
rsQuelle.MoveNext
Loop
rsSenke.UpdateBatch
End If
rsSenke.Close
cnnSenke.Close
End If
rsQuelle.Close
cnnQuelle.Close
Raus:
If Not rsQuelle Is Nothing Then
If rsQuelle.State = adStateOpen Then rsQuelle.Close
End If
Set rsQuelle = Nothing
If Not rsSenke Is Nothing Then
If rsSenke.State = adStateOpen Then rsSenke.Close
End If
Set rsSenke = Nothing
If Not cnnQuelle Is Nothing Then
If cnnQuelle.State = adStateOpen Then cnnQuelle.Close
End If
Set cnnQuelle = Nothing
If Not cnnSenke Is Nothing Then
If cnnSenke.State = adStateOpen Then cnnSenke.Close
End If
Set cnnSenke = Nothing
Exit Sub
Fehler:
MsgBox "Fehler: " & CStr(Err.Number) & " " & Err.Description, vbCritical, "subImport"
Resume Raus
End Sub