Registriert seit: 22.03.2021
Version(en): 365
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
00202
Nicht registrierter Gast
Hallo, muss es VBA sein? Hier bietet sich doch " Power Query - aka Daten abrufen..." an. Hier ein Einstieg dazu: PQ 1...PQ2...Damit geht das schnell und effektiv. Unabhängig davon - mit VBA auch.
Registriert seit: 05.09.2019
Version(en): Office 365
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
Registriert seit: 22.03.2021
Version(en): 365
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
Registriert seit: 05.09.2019
Version(en): Office 365
22.06.2022, 09:54
(Dieser Beitrag wurde zuletzt bearbeitet: 22.06.2022, 10:04 von UweD.)
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
Registriert seit: 22.03.2021
Version(en): 365
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
Registriert seit: 05.09.2019
Version(en): Office 365
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
Registriert seit: 22.03.2021
Version(en): 365
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?
Registriert seit: 05.09.2019
Version(en): Office 365
Hallo
bei mir klappt es.
Da wirst du wohl mal 2 Dateien hochladen müssen.
LG UweD
Registriert seit: 22.03.2021
Version(en): 365
27.06.2022, 14:45
(Dieser Beitrag wurde zuletzt bearbeitet: 27.06.2022, 14:45 von SimonVBA.
Bearbeitungsgrund: Zusätzliche Information
)
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
|