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ühren

Daten aus mehreren Tabellen zusammenführen
18.12.2017 11:50:35
Pat
Hallo liebes Forum!
Ich hatte bisher wenig mit VBA zutun und habe nun folgendes Problem:
Ich möchte mit einem Makro aus einem bestimmten Ordner ("H:\Test\Berichte\") alle Excel Dateien ansprechen und die Daten aus den jeweiligen „Tabelle1“ (ab Zeile 2) in eine „MasterTabelle 1“ hinein kopieren.
Die Daten sollen sich nacheinander in der „MasterTabelle1“ automatisch in der nächsten freien Zeile einfügen.
Auch wäre es interessant zu wissen, wie man nur z.B. die letzten 7 oder 14 letzten Zeilen auslesen kann in den jeweiligen Excel-Dateien.
Hatte auch hier
https://www.online-vba.de/vba_datensammeln5.php
ein ähnliches Beispiel gefunden aber bin leider zu unfähig es funktionierend umzubauen.
Vielen Dank im Voraus!

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 13:39:21
UweD
Hallo
so?
Sub alle_Dateien_Verzeichnis2() ' 
    On Error GoTo Fehler
    Dim Pfad$, Ext$, Datei$, TB1, TB2, LR1 As Double, LR2 As Double
    Dim SP As Integer, EZ As Integer, XZeilen As Integer, MaxZeilen As Integer
    
    
    Ext = "*.xlsx"
    Pfad = "X:\Temp\Test\" '**** mit \ 
    Set TB1 = ThisWorkbook.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
    
        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
        
        '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
Anzeige
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 14:16:44
Pat
Hi Uwe,
es funktioniert! Tausend Dank!
Musste bei dir nur " Ext = "*.xlsx" " ersetzen mit " Ext = "*.xl*" ".
Prima! Danke für die Rückmeldung. owT
18.12.2017 14:20:47
UweD
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 13:48:06
JoWE
Hallo Pat,
vllt. so:
Option Explicit
Sub Tabellen1_aus_Arbeitsmappen_eines_Ordners_in_eine_Arbeistmappe_zusammenfuegen()
Dim fileName
ChDrive "H:"
ChDir "H:\Test\Berichte"
Dim vntPathAndFileNames As Variant
Dim strPathAndFile As String
Dim lngI As Long
Dim wbkMappe As Workbook
Dim wksT As Worksheet
Dim wbkZiel As Workbook
Set wbkZiel = ThisWorkbook 'die Arbeitsmappe die diesenCode enthält und alle Daten aufnimmt
vntPathAndFileNames = Application.GetOpenFilename( _
FileFilter:="Berichte (*.xls*), *.xls*", _
Title:="Die erwünschten Dateien mit gedrückter Strg Taste markieren!", _
MultiSelect:=True)
If VarType(vntPathAndFileNames) = vbBoolean Then
MsgBox "Abgebrochen!"
Else
For lngI = LBound(vntPathAndFileNames) To UBound(vntPathAndFileNames)
strPathAndFile = vntPathAndFileNames(lngI)
Set wbkMappe = Application.Workbooks.Open(strPathAndFile)
'Bereich der zu kopierenden Daten anpassen
wbkMappe.Sheets("Tabelle1").Range("A2:F200").Copy _
wbkZiel.Sheets(1).Cells(wbkZiel.Sheets(1). _
Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
wbkMappe.Close False
Next
End If
End Sub
Gruß
Jochen
Anzeige
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 14:31:13
Pat
Auch super gelöst! Vielen Dank
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 14:43:28
Pat
Ich hätte noch eine Frage auch wenn es wahrscheinlich nicht möglich ist:
Kann man die Daten aus den einzelnen Datensätzen (Zeilen) aus Tabelle1 abgleichen mit denen aus der MasterTabelle1? Sodass nur die aktuellen (noch nicht vorhandenen) Datensätze in die MasterTabelle1 hinzugefügt werden?
Viele Grüße
AW: Daten aus mehreren Tabellen zusammenführen
18.12.2017 15:03:46
UweD
Ja, geht
- zeilenweise in einer Schleife
- bei eindeutigem Schlüssel
- Weiter, wenn du Beispieldateien hochlädst
LG UweD
AW: Daten aus mehreren Tabellen zusammenführen
19.12.2017 10:43:27
Pat
Hi,
habe mal 3 Test-Excel-Dateien angelegt und eine „MasterDatei“. (Der Pfad zum Ornder muss benutzerspez. geändert werden)
Die MasterDatei holt sich alle Daten aus den Tabellen „Tabelle1“ aus dem Ordner „Test“.
Das funktioniert dank Uwe schon wunderbar!
Jetzt würde ich gerne alle einzelnen Zeilen aus Tabelle1 (Test) abgleichen mit den vorhandenen Zeilen in der MasterDatei. Wenn sich die komplette Zeile aus Tabelle1 gleich ist wie die vorhandene soll keine Kopie erstellt werden in der MasterDatei. (Damit keine doppelten Datensätze entstehen)
Vielen Dank für deine bisherige Hilfe, Uwe! Vielleicht kannst du mir noch ein paar Tipps geben =)
Hier die gezipten Dateien: https://www.herber.de/bbs/user/118416.zip
Anzeige
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
Anzeige

344 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige