Daten aus mehreren Tabellen zusammenführen2
17.04.2018 08:59:35
Pat
habe Frage zu einem Thema, welches schon im Archiv ist, hier der Link:
https://www.herber.de/forum/archiv/1596to1600/1597784_Daten_aus_mehreren_Tabellen_zusammenfuehren.html#1598110
Um es mal zusammenzufassen:
Es werden alle einzelnen Zeilen aus Tabelle1 verglichen mit den vorhandenen Zeilen in der "MasterDatei". Wenn die komplette Zeile aus Tabelle1 gleich ist wie die vorhandene soll keine Kopie erstellt werden in der "MasterDatei". (Damit keine doppelten Datensätze entstehen)
Hier der Code von UweD:
Option Explicit
Sub alle_Dateien_Verzeichnis2()
On Error GoTo Fehler
Dim Pfad As String, Ext As String, Datei As String
Dim WB As String, TB1, TB2, LR1 As Double, LR2 As Double, LC2 As Integer
Dim SP As Integer, EZ As Integer, XZeilen As Integer, MaxZeilen As Integer
Application.ScreenUpdating = False 'Das "Flackern" ausstellen = False
Application.DisplayAlerts = True 'Keine Fehlermeldungen anzeigen = False
Ext = "*.xl*"
Pfad = "C:\test\" '**** mit \
Pfad = "x:\temp\test\" '**** mit \
WB = ThisWorkbook.Name
Set TB1 = Workbooks(WB).Sheets("MasterTabelle1") 'das Sammelblatt
SP = 1 'erste Datenspalte
EZ = 2 'Ab Zeile2 / wegen Überschriften
'XZeilen = 7 ' letzen x Zeilen
Datei = Dir(Pfad & Ext)
Do While Len(Datei) > 0 And Datei WB
Workbooks.Open Filename:=Pfad & Datei
Set TB2 = ActiveWorkbook.Sheets("Tabelle1")
LR1 = TB1.Cells(TB1.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
LR2 = TB2.Cells(TB2.Rows.Count, SP).End(xlUp).Row
LC2 = TB2.Cells(1, TB2.Columns.Count).End(xlToLeft).Column + 1 ' erste freie Spalte
'nur Neue
With TB2
'Zählenwenns, ob schon vorhanden (Vergleichen Vorname+Name+Ort
.Cells(1, LC2) = "Temp"
.Range(.Cells(EZ, LC2), .Cells(LR2, LC2)).FormulaR1C1 = _
"=COUNTIFS([" & WB & "]" & TB1.Name & "!C1,RC1,[" & _
WB & "]" & TB1.Name & "!C2,RC2,[" & _
WB & "]" & TB1.Name & "!C3,RC3)"
If WorksheetFunction.CountIf(.Columns(LC2), 0) > 0 Then ' sind neue Zeilen da
'Neue filten
.Columns(LC2).AutoFilter Field:=1, Criteria1:="=0", Operator:=xlAnd
'dann copieren
TB2.Cells(EZ, 1).Resize(LR2 - EZ + 1, LC2 - 1).Copy _
TB1.Cells(LR1 + 1, 1)
End If
End With
Workbooks(Datei).Close False 'schliessen ohne speichern
Datei = Dir() ' nächste Datei
Loop
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End
Sub
Ich benutze das Makro häufig und es erleichtert mir sehr das Leben. Nur eine Sache ist mir _
Aufgefallen:
Für das Zählen, ob Wert schon vorhanden (Vergleichen der Spalten) werden Spalte A,B,E und F _
verwendet.
Leider funktioniert das Makro nicht wenn in besagter Zelle NICHTS eingetragen wird.
Beim Ausführen des Makros werden einfach die Zeilen mit der leeren Zeile kopiert, obwohl diese _
Zeile bereits vorhanden ist.
Weiß ehrlich gesagt überhaupt nicht wie ich diese Problem beheben kann :-(
Viele Grüße und herzlichen Dank für Eure Hilfe!
Pat