AW: Daten aus mehreren Tabellen zusammenführen
19.12.2017 15:53:34
UweD
Hallo
so...
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
'alle Daten kopieren
'TB1.Rows(LR1 + 1).Resize(LR2 - EZ + 1).Value = _
TB2.Rows(EZ).Resize(LR2 - EZ + 1).Value
'oder letzten X
'MaxZeilen = WorksheetFunction.Min(LR2 - EZ + 1, XZeilen) 'Wenn weniger als XZeilen vorhanden
'TB1.Rows(LR1 + 1).Resize(MaxZeilen).Value = _
'TB2.Rows(LR2 - MaxZeilen + 1).Resize(MaxZeilen).Value
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
LG UweD