Daten aus anderer Excel-Datei kopieren + Abgleich

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Daten aus anderer Excel-Datei kopieren + Abgleich
von: Sebastian
Geschrieben am: 19.10.2015 17:27:59

Hallo liebes Forum,
ich habe exakt das gleiche Problem wie hier beschrieben:
https://www.herber.de/forum/archiv/1324to1328/1324199_Daten_aus_anderer_ExcelDatei_einfuegen.html#1324199
Das Makro funktioniert auch richtig klasse, nur benötige ich es modifiziert: die neuen Daten sollen nicht automatisch dazugefügt werden, sondern es soll vorher abgeglichen werden, ob die einzufügenden Daten bereits in der Zieltabelle vorhanden sind und nur dann kopiert werden, wenn sie noch nicht vorhanden sind.
https://www.herber.de/bbs/user/100874.xlsm
Könnte mir wer freundlicherweise das vorhandene Makro so umschreiben, dass es nur "neue" bzw. nicht bereits vorhandene Daten kopiert?
Herzlichsten Dank!!

Bild

Betrifft: AW: Daten aus anderer Excel-Datei kopieren + Abgleich
von: Sebastian
Geschrieben am: 20.10.2015 13:24:29
Bitte, ich benötige nur eine Schleife im Code, die prüft (anhand Spalte 1), ob Zeilen, die aus der Quelldatei rüberkopiert werden sollen, bereits in der Zieltabelle ("Tabelle 1") vorhanden ist und diese dann NICHT mitkopiert. Ihr würdet mir wahnsinnig helfen!

Sub DateiNeuauswählen()
  With Application.FileDialog(msoFileDialogOpen)
    .Title = "Bitte Datei mit den neuen Daten auswählen"
    .FilterIndex = 1
    If .Show = -1 Then
      wksSteuerung.Range("A5") = .SelectedItems(1)
    End If
  End With
End Sub
Sub Daten_aktualisieren()
  Dim strPfadDatei As String, strDatei As String
  Dim wksZiel As Worksheet
  Dim wkbNeu As Workbook, wksNeu As Worksheet, bolOpen As Boolean
  Dim lngZeileNeu As Long, lngZeileTitelNeu As Long, strTitelNeu As String
  Dim lngZeileZiel As Long, lngZeileTitelZiel As Long, strTitelZiel As String
  Dim lngSpalteZiel As Long, rngZelle As Range
  Dim lngSpalteNeu As Long, lngSpalte As Long
  Set wksZiel = ActiveWorkbook.Worksheets("Tabelle1")
  
  
  With wksSteuerung
    With .Range("A5")
      If .Value = "" Then
        MsgBox "Bitte die Datei mit den neuen Daten auswählen"
      ElseIf Dir(.Text) = "" Then
        MsgBox "Die Datei """ & .Text & """ existiert nicht!" & vbLf _
          & "Bitte andere Datei mit neuen Daten auswählen!"
      Else
        strPfadDatei = .Text
        strDatei = Mid(strPfadDatei, InStrRev(strPfadDatei, Application.PathSeparator) + 1)
      End If
    End With
    lngZeileTitelNeu = .Range("E5")
    lngZeileTitelZiel = .Range("E6")
  End With
      
  Application.ScreenUpdating = False
  'Prüfen, ob Datei mit neuen Daten schon geöffnet
  For Each wkbNeu In Application.Workbooks
    If LCase(wkbNeu.Name) = LCase(strDatei) Then
      bolOpen = True
      Exit For
    End If
  Next
  
  If wkbNeu Is Nothing Then
    'Datei mit neuen Daten schreibgeschützt öffnen
    Set wkbNeu = Application.Workbooks.Open(Filename:=strPfadDatei, ReadOnly:=True)
    bolOpen = False
  End If
  Set wksNeu = wkbNeu.Worksheets(1)
  
  'Nächste freie Zeile in aktuellen Daten
  lngZeileZiel = fncLetzteZeilemitDaten(wks:=wksZiel) + 1
  'letzte Zeile mit Daten im Blatt mit neuen Daten
  lngZeileNeu = fncLetzteZeilemitDaten(wks:=wksNeu)
  If lngZeileNeu <= lngZeileTitelNeu Then
    MsgBox "Keine Daten in der Datei mit neuen neuen Daten"
    GoTo Beenden
  End If
  'Spaltentitel im Blatt Steuerung abarbeiten
  For lngSpalte = 2 To wksSteuerung.Cells(9, wksSteuerung.Columns.Count).End(xlToLeft).Column
    strTitelZiel = wksSteuerung.Cells(9, lngSpalte).Text
    strTitelNeu = wksSteuerung.Cells(10, lngSpalte).Text
    
    If strTitelZiel = "Frei" Or strTitelZiel = "" Then
      'do nothing
    Else
      Set rngZelle = wksZiel.Rows(lngZeileTitelZiel).Find(what:=strTitelZiel, _
            LookIn:=xlValues, lookat:=xlWhole)
      If rngZelle Is Nothing Then
        'Spaltentitel ist im Zielblatt nicht vorhanden - do nothing
      Else
        lngSpalteZiel = rngZelle.Column
        
        Set rngZelle = wksNeu.Rows(lngZeileTitelNeu).Find(what:=strTitelNeu, _
            LookIn:=xlValues, lookat:=xlWhole)
        If rngZelle Is Nothing Then
          'Spaltentitel ist im neuen Blatt nicht vorhanden - do nothing
        Else
          lngSpalteNeu = rngZelle.Column
          With wksNeu
            .Range(.Cells(lngZeileTitelNeu + 1, lngSpalteNeu), _
                   .Cells(lngZeileNeu, lngSpalteNeu)).Copy _
                   Destination:=wksZiel.Cells(lngZeileZiel, lngSpalteZiel)
          End With
        End If
      End If
    End If
  Next
Beenden:
  'Quelldatei ggf. wieder schliessen
  If bolOpen = False Then
    wkbNeu.Close savechanges:=False
  End If
  
  wksZiel.Activate
  Application.ScreenUpdating = True
  MsgBox "Fertig", vbOKOnly, "Daten aktualisieren"
  Set wkbNeu = Nothing: Set wksNeu = Nothing: Set wksZiel = Nothing
  Set rngZelle = Nothing
End Sub
Public Function fncLetzteZeilemitDaten(Optional ByVal wks As Worksheet) As Long
  Dim rngZelle As Range
  If wks Is Nothing Then Set wks = ActiveSheet
  With wks
    Set rngZelle = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
      lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
    If rngZelle Is Nothing Then
      'Tabellenblatt ist leer
      fncLetzteZeilemitDaten = 0
    ElseIf rngZelle.Row = .Rows.Count Then
      MsgBox "Keine freie Zeile mehr im Blatt, Ergegebniszeile = -1"
      fncLetzteZeilemitDaten = -1
    Else
      fncLetzteZeilemitDaten = rngZelle.Row
    End If
  End With
End Function


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Daten aus anderer Excel-Datei kopieren + Abgleich"