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
Registriert seit: 30.08.2014
Version(en): Office 365 - Beta 32 Bit
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. 
________
Servus
Case
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, 08:54
(Dieser Beitrag wurde zuletzt bearbeitet: 22.06.2022, 09: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, 13:45
(Dieser Beitrag wurde zuletzt bearbeitet: 27.06.2022, 13: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
|
