Dateien aus einem Ordner in Masterdatei kopieren
#1
Hallo zusammen, 

ich bin auf der Suche nach einem Makro welche folgende Funktion ausführt: 

in P:\Monat liegt eine Masterdatei, in P:\Monat\Feedback liegen mehrere Dateien mit unterschiedlich vielen Zeilen (die Spaltenanzahl ist immer identisch)

Der Pfad P:\Monat\Feedback wechselt monatlich und soll aus Zelle A1 abgelesen werden.
Die Dateien aus P:\Monat\Feedback sollen nun nacheinander geöffnet werden, der Bereich A7:Z kopiert und in die Masterdatei untereinander eingefügt werden. 
Beim Einfügen sollen möglichst keine Leerzeilen zurückbleiben. 


Optional: der Ordner P:\Feedback wird immer wieder mit neuen Daten gespeist, bei erneutem Ausführen des Makros sollen nur neue Dateien berücksichtigt werden. 

Falls meine Ausführung nicht detailliert genug war, gerne Rückfragen stellen. 

Vielen Dank im Voraus!
SimonVBA
Antworten Top
#2
Hallo, 19 

muss es VBA sein? Hier bietet sich doch "Power Query - aka Daten abrufen..." an. 21 

Hier ein Einstieg dazu: Dodgy 

PQ 1...
PQ2...

Damit geht das schnell und effektiv. Unabhängig davon - mit VBA auch. Blush
Antworten Top
#3
Hallo

Ich hoffe, ich hab es richtig verstanden

Diesen Code in ein normales Modul in der Masterdatei.xlsm
Code:
Sub Simon()
    Dim WbM As Workbook, TbM As Worksheet
    Dim WbX As Workbook, TbX As Worksheet, TaBname As String, TB3 As Worksheet
    Dim LR As Long, RR As Long, Zeile As Long, Z1 As Integer
    Dim PfadQ As String
    Dim Ext As String, Datei As String, Anz As Long
   
    Application.ScreenUpdating = False
   
    Set WbM = ThisWorkbook
    Set TbM = WbM.Sheets("Tabelle1") 'das Zielblatt
    TaBname = "Tabelle1" 'Name des Quellblattes
   
    Set TB3 = WbM.Sheets("Merker") ' Blatt um die gelesenen Tabellen zu merken
   
    Z1 = 7 'Kopieren ab
    Ext = "*.xlsx"
    Zeile = 5 'Beispiel erste Zielzeile
   
   
    PfadQ = TbM.Range("A1") & "\" 'Quellpfad
    PfadQ = Replace(PfadQ, "\\", "\") ' ggf doppelte \ am Ende antfernen
   
    If Dir(PfadQ, vbDirectory) = "" Then
        MsgBox "Quellpfad existiert nicht"
        Exit Sub
    End If
   
   
    Datei = Dir(PfadQ & Ext)
    Do While Len(Datei) > 0
   
        If WorksheetFunction.CountIf(TB3.Columns(1), Datei) = 0 Then
            'prüfen, ob schon bearbeitet
       
            LR = TB3.Cells(TB3.Rows.Count, "A").End(xlUp).Row + 1 'erste freie Zeile der Spalte
            TB3.Cells(LR, 1) = Datei 'Datei merken
       
            Set WbX = Workbooks.Open(Filename:=PfadQ & Datei)
            Set TbX = WbX.Sheets(TaBname)
           
            RR = TbX.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
            Anz = RR - Z1 + 1 'Anzahl der zu kopierenden Zeilen
           
            TbX.Cells(Z1, 1).Resize(Anz, 26).Copy TbM.Cells(Zeile, 1)
            Zeile = Zeile + Anz
       
            WbX.Close False 'schließen ohne speichern
        End If
       
        Datei = Dir() ' nächste Datei
    Loop

End Sub

Zum Merken der bereits verarbeiteten Dateien habe ich ein neues Blatt angelegt (Merker) das kannst du auch später ausblenden.
Dort werden die Dateinamen in Spalte A reingeschrieben.

LG UweD
Antworten Top
#4
Hallo UweD, 

vielen Dank für dein Code, es läuft soweit auch durch, kopiert allerdings nur das die erste Datei in die Zieldatei. 

Alle weiteren Dateien werden zwar in das Blatt "Merker" geschrieben, aber nicht kopiert.. 

Viele Grüße
Simon
Antworten Top
#5
Hallo nochmal

- Zeig mal genau die Verzeichnisstruktur (Screenshot aus dem DateiExplorer)
- und ein bis 2 die Dateien, die dort liegen 


Hier mal mit Zählfunktion um zu sehen, was gemacht wird.

Code:
Sub Simon()
    Dim WbM As Workbook, TbM As Worksheet
    Dim WbX As Workbook, TbX As Worksheet, TaBname As String, TB3 As Worksheet
    Dim LR As Long, RR As Long, Zeile As Long, Z1 As Integer
    Dim PfadQ As String
    Dim Ext As String, Datei As String, Anz As Long, D1 As Integer, D2 As Integer
   
    Application.ScreenUpdating = False
   
    Set WbM = ThisWorkbook
    Set TbM = WbM.Sheets("Tabelle1")
    TaBname = "Tabelle1" 'Name des Quellblattes
   
    Set TB3 = WbM.Sheets("Merker") ' Blatt um die gelesenen Tabellen zu merken
   
    Z1 = 7 'Kopieren ab
    Ext = "*.xlsx"
    Zeile = 5 'Beispiel erste Zielzeile
   
   
    PfadQ = TbM.Range("A1") & "\" 'Quellpfad
    PfadQ = Replace(PfadQ, "\\", "\") ' ggf doppelte \ am Ende antfernen
   
    If Dir(PfadQ, vbDirectory) = "" Then
        MsgBox "Quellpfad existiert nicht"
        Exit Sub
    End If
   
   
    Datei = Dir(PfadQ & Ext)
    Do While Len(Datei) > 0
   
        D1 = D1 + 1 'zählen vorgefunden
       
        If WorksheetFunction.CountIf(TB3.Columns(1), Datei) = 0 Then
            'prüfen, ob schon bearbeitet
           
            D2 = D2 + 1 'zählen neu geladen
           
            LR = TB3.Cells(TB3.Rows.Count, "A").End(xlUp).Row + 1 'erste freie Zeile der Spalte
            TB3.Cells(LR, 1) = Datei 'Datei merken
       
            Set WbX = Workbooks.Open(Filename:=PfadQ & Datei)
            Set TbX = WbX.Sheets(TaBname)
           
            RR = TbX.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
            Anz = RR - Z1 + 1 'Anzahl der zu kopierenden Zeilen
           
            TbX.Cells(Z1, 1).Resize(Anz, 26).Copy TbM.Cells(Zeile, 1)
            Zeile = Zeile + Anz
       
            WbX.Close False 'schließen ohne speichern
        End If
       
        Datei = Dir() ' nächste Datei
    Loop
   
    MsgBox D1 & ":  Dateien vorgefunden" & vbLf & vbLf & _
           D2 & ":  davon neu verarbeitet"

End Sub


LG UweD
Antworten Top
#6
Hi, 

S:\Sales\Reporting\2022\05_May\Feedback --> wird aus A1 gelesen

Dateinamen:

Sales_Reporting_2022_05_May_DE
Sales_Reporting_2022_05_May_UK
Sales_Reporting_2022_05_May_US


Alle Dateien sind im Aufbau gleich und die Daten beginnen ab A7, dies ist aber auch im Makro berücksichtigt und funktioniert auch für die erste Datei. 

Viele Grüße
Simon
Antworten Top
#7
Hallo

Ok. hat immer wieder bei Zeile 5 angefangen.

Versuch es mal so
Code:
Sub Simon()
    Dim WbM As Workbook, TbM As Worksheet
    Dim WbX As Workbook, TbX As Worksheet, TaBname As String, TB3 As Worksheet
    Dim LR As Long, RR As Long, Zeile As Long, Z1 As Integer
    Dim PfadQ As String
    Dim Ext As String, Datei As String, Anz As Long, D1 As Integer, D2 As Integer
   
    Application.ScreenUpdating = False
   
    Set WbM = ThisWorkbook
    Set TbM = WbM.Sheets("Tabelle1")
    TaBname = "Tabelle1" 'Name des Quellblattes
   
    Set TB3 = WbM.Sheets("Merker") ' Blatt um die gelesenen Tabellen zu merken
   
    Z1 = 7 'Kopieren ab
    Ext = "*.xlsx"
    Zeile = 5 'Beispiel erste Zielzeile
   
   
    PfadQ = TbM.Range("A1") & "\" 'Quellpfad
    PfadQ = Replace(PfadQ, "\\", "\") ' ggf doppelte \ am Ende antfernen
   
    If Dir(PfadQ, vbDirectory) = "" Then
        MsgBox "Quellpfad existiert nicht"
        Exit Sub
    End If
   
   
    Datei = Dir(PfadQ & Ext)
    Do While Len(Datei) > 0
   
        D1 = D1 + 1 'zählen vorgefunden
       
        If WorksheetFunction.CountIf(TB3.Columns(1), Datei) = 0 Then
            'prüfen, ob schon bearbeitet
           
            D2 = D2 + 1 'zählen neu geladen
           
            LR = TB3.Cells(TB3.Rows.Count, "A").End(xlUp).Row + 1 'erste freie Zeile der Spalte
            TB3.Cells(LR, 1) = Datei 'Datei merken
       
            Set WbX = Workbooks.Open(Filename:=PfadQ & Datei)
            Set TbX = WbX.Sheets(TaBname)
           
            'Letzte QuellZeile
            RR = TbX.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
           
            'Freie Zielzeile, mind. aber 5
            Zeile = WorksheetFunction.Max(Zeile, TbM.Cells.SpecialCells(xlCellTypeLastCell).Row + 1)
           
            Anz = RR - Z1 + 1 'Anzahl der zu kopierenden Zeilen
           
            TbX.Cells(Z1, 1).Resize(Anz, 26).Copy TbM.Cells(Zeile, 1)
       
            WbX.Close False 'schließen ohne speichern
        End If
       
        Datei = Dir() ' nächste Datei
    Loop
   
    MsgBox D1 & ":  Dateien vorgefunden" & vbLf & vbLf & _
           D2 & ":  davon neu verarbeitet"

End Sub
Antworten Top
#8
Jetzt kopiert er mir leider gar nichts mehr.. die Daten beginnen ab Zeile 7, sowohl in der Quell- als auch in der Zieldatei.

Dies habe ich im Makro wie folgt angegeben: 
Code:
Z1 = 7 'Kopieren ab
    Ext = "*.xlsm"
    Zeile = 7 'Beispiel erste Zielzeile

Liegt hier vielleicht der Fehler?
Antworten Top
#9
Hallo

bei mir klappt es.

Da wirst du wohl mal 2 Dateien hochladen müssen.

LG UweD
Antworten Top
#10
Sorry für die späte Rückmeldung, mir ist was dazwischen gekommen. Das Makro läuft sauber durch, kopiert die Spalten auch aber es tritt die Fehlermeldung "Excel kann die Daten nicht einfügen" auf. 
Die Tabellen sind komplett identisch, die Feedback-Tabellen werden aus der Quell- und später auch Zieltabelle generiert. Ich kann diesen Fehler also nciht wirklich nachvollziehen. 
Wenn ich das Makro manuell durchlaufen lassen und dann den Zwischenspeicher in einer neue EXCEL einfüge funktioniert es..

Viele Grüße
Simon
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste