Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Daten aus mehreren Tabellen zusammenführen2


Betrifft: Daten aus mehreren Tabellen zusammenführen2 von: Pat
Geschrieben am: 17.04.2018 08:59:35

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


  

Betrifft: Probier mal das: von: Mirko
Geschrieben am: 19.04.2018 11:09:53

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

'<<< unten drunter; vor „End Sub“

Else

MsgBox "!Achtung! – Datei ist leer!”


End If '<- den nicht vergessen
Ggf. musst Du es noch ein wenig anpassen

VG

Mirko


Beiträge aus dem Excel-Forum zum Thema "Daten aus mehreren Tabellen zusammenführen2"