Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten aus mehreren Tabellen zusammenführen2

Daten aus mehreren Tabellen zusammenführen2
17.04.2018 08:59:35
Pat
Hallo liebes Forum und besonders UweD,
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


		

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Probier mal das:
19.04.2018 11:09:53
Mirko
Hallo Pat,
ich hab mir für solche Fälle mit Anregung aus einem anderen Forum ein „GetValue“ gebaut, was für mich nachschaut, ob in einem Tabellenblatt meiner Walt in einer bestimmten Zelle was drin steht oder nicht und erst dann den „Rest“ tut.
Vorteile sind hier, dass ich dieses Value nur einmal in der Funktion deklariere und innerhalb meines Marcos z.B. bei drei verschiedenen Dateien / Tabellenblättern nutzen kann UND ich muss die zu prüfende Datei nicht mal öffnen.
Das sieht dann so aus
…Zuerst die Variable mit der Funktion erstellen:

Private Function GetValue(pfad, datei, blatt, zelle)
'Dimensionierung der Variablen
Dim arg As String
'Sicherstellen, dass das datei vorhanden ist
If Right(pfad, 1)  "\" Then pfad = pfad & "\"
If Dir(pfad & datei) = "" Then
GetValue = "datei Not Found"
Exit Function
End If
'Argumente erstellen
arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(zelle).Range("A1").Address(, ,  _
xlR1C1)
'Auslesen über Excel4Macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Dann Prüfen am Anfang des „Sub“, ob Tabelleninhalt Deiner Wahl leer:

'Dimensionierung der Variablen zum Auslesen
Dim pfadP As String, dateiP As String, blattP As String, zelleP As String, WertP As Long
' Angaben zu den auszulesenden Zellen
pfadP = "Laufwerk:\Ordner\Unterordner" 'Pfad, wo die zu prüfende Datei liegt
dateiP = "Quelle.xlsx" 'hier den Namen Deiner zu prüfenden Datei rein
blattP = "Blattname" 'hier den Namen des Ziel-Blattes aus Deiner zu prüfenden Datei rein
ZelleP = "A3" 'hier die Zelle rein, in der entweder normalerweise was steht oder auch nicht
' Werte nun zusammen setzen:
WertP = GetValue(pfadP, dateiP, blattP, ZelleP)
'Und nun kannst Du los legen mit „If“:
If WertP  “” Then
'>>> ab hier der ganze Rest Code
'
Ggf. musst Du es noch ein wenig anpassen
VG
Mirko
Anzeige

343 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige