Hallo xvba,

richtig. Du wolltest ja den Import mit ADO. Wenn Du die Quelltabelle nicht einfach verknüpfen willst, probier doch mal diese Lösung.

Falls die ID in der Senke als Feld ohne Duplikate definiert ist, müsste noch eine entsprechende Fehlerroutine eingebaut werden.

Viel Erfolg

Heiko

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" 'Quell-DB
  Const c_strUserID As String = "Admin"
  Const c_strQuellTBL As String = "Tabelle2"  'in der Quell-DB
  Const c_strSenkeTBL As String = "Tabelle1"  'in dieser Datenbank

  Dim cnnQuelle As ADODB.Connection
  Dim rsQuelle As ADODB.Recordset
  Dim strSQL As String
  
  Dim cnnSenke As ADODB.Connection
  Dim rsSenke As ADODB.Recordset
  
  'Felder der Quell-Tabelle
  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 'Felder der Senke-Tabelle
          .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