Datenimport aus Wochenberichten

Hallo Zusammen,

ich arbeite gerade an einer Lösung, wie ich alle Daten mit der Dateiendung .xlsx aus einem Ordner auf meinem Desktop "Wochenberichte" öffne, Daten aus dem Blatt "Wochenbericht" nach einem bestimmten Schema kopiere und in einer Masterdatei "Wochenberichte" Blatt "data" importiere.

Ich habe schon viel mit ChatGPT versucht, bin aber nie nahe an eine finale Lösung ran gekommen. Die Dateien wurden zwar geöffnet aber der Inhalt kreuz und quer in der Zieldatei eingefügt.

Ordner: Wochenberichte Rohdaten

Zieldatei: Wochenberichte Blatt data
https://www.herber.de/bbs/user/158773.xlsx

Quelldatei: Wochenbericht KWxy (Name ist variabel) Blatt Wochenbericht
https://www.herber.de/bbs/user/158777.xlsx

Kopiert werden soll wie folgt:
Von Quelldatei nach Zieldatei

B3:B6 nach A3:D3
E4:E6 nach E3:G3
B8:B18 nach H3:R3
E8:E18 nach S3:AC3
H8:H18 nach AD2:AN3

B21:B31 nach AO3:AY3
E21:E31 nach AZ3:BJ3
H21:H31 nach BK3:BU3

B34:B44 nach BV3:CF3
E34:E44 nach CG3:CQ3
H34:H44 nach CR3:DB3

B47:B57 nach DC3:DM3
E47:E57 nach DN3:DX3
H47:H57 nach DY3:EI3

B59 nach EJ3

Danach die nächste Datei eine Zeile tiefer

ChatGPT hat folgenden Code für mich geschrieben und hat leider immer einfach aufgehört zu schreiben.
Hier ein Beispiel:

Sub DatenInWochenberichtKopieren()
    
    'Variablen deklarieren
    Dim Pfad As String
    Dim Dateiname As String
    Dim wbZiel As Workbook
    Dim wsZiel As Worksheet
    
    'Pfad zum Ordner mit den Quelldateien angeben
    Pfad = "C:\Pfad\zum\Ordner\mit\Quelldateien\"
    
    'Erste Datei im Ordner auswählen
    Dateiname = Dir(Pfad & "*.xlsx")
    
    'Loop über alle Dateien im Ordner
    Do While Dateiname > ""
        
        'Quelldatei öffnen
        Workbooks.Open (Pfad & Dateiname)
        
        'Zieldatei öffnen
        Set wbZiel = ThisWorkbook
        
        'Zielblatt auswählen
        Set wsZiel = wbZiel.Sheets("data")
        
        'Daten von Quelldatei in Zieldatei kopieren
        wsZiel.Range("A3") = ActiveWorkbook.Sheets(1).Range("B3")
        wsZiel.Range("B3") = ActiveWorkbook.Sheets(1).Range("B4")
        wsZiel.Range("C3") = ActiveWorkbook.Sheets(1).Range("B5")
        wsZiel.Range("D3") = ActiveWorkbook.Sheets(1).Range("B6")
        
        wsZiel.Range("E3") = ActiveWorkbook.Sheets(1).Range("E4")
        wsZiel.Range("F3") = ActiveWorkbook.Sheets(1).Range("E5")
        wsZiel.Range("G3") = ActiveWorkbook.Sheets(1).Range("E6")
        
        wsZiel.Range("H3") = ActiveWorkbook.Sheets(1).Range("B8")
        wsZiel.Range("I3") = ActiveWorkbook.Sheets(1).Range("B9")
        wsZiel.Range("J3") = ActiveWorkbook.Sheets(1).Range("B10")
        wsZiel.Range("K3") = ActiveWorkbook.Sheets(1).Range("B11")
        wsZiel.Range("L3") = ActiveWorkbook.Sheets(1).Range("B12")
        wsZiel.Range("M3") = ActiveWorkbook.Sheets(1).Range("B13")
        wsZiel.Range("N3") = ActiveWorkbook.Sheets(1).Range("B14")
        wsZiel.Range("O3") = ActiveWorkbook.Sheets(1).Range("B15")
        wsZiel.Range("P3") = ActiveWorkbook.Sheets(1).Range("B16")
        wsZiel.Range("Q3") = ActiveWorkbook.Sheets(1).Range("B17")
        wsZiel.Range("R3") = ActiveWorkbook.Sheets(1).Range("B18")
        
        wsZiel.Range("EJ3") = ActiveWorkbook.Sheets(1).Range("B59")
        
        'Quelldatei schließen
        Workbooks(Dateiname).Close
        
        'Nächste Datei im Ordner auswählen
        Dateiname = Dir
        
        'Zielzeile für nächste Datei um 1 erhöhen
        Set wsZiel = wbZiel.Sheets("Wochenbericht")
        wsZiel

Eventuell hat ja jemand atok eine Idee wie man das "einfach" umsetzen kann.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub KopiereBericht() Dim wsBericht As Worksheet Dim wsZiel As Worksheet Dim EinfRowZiel As Long Dim Pfad As String Dim Dateiname As String Application.ScreenUpdating = False Pfad = "C:\test\" 'anpassen Set wsZiel = ThisWorkbook.Worksheets("t") Dateiname = Dir(Pfad & "*.xlsx") Do While Dateiname > "" Workbooks.Open (Pfad & Dateiname) Set wsBericht = Worksheets("Wochenbericht") EinfRowZiel = wsZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1 wsBericht.Range("B3:B6").Copy wsZiel.Range("A" & EinfRowZiel).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True wsBericht.Range("E4:E6").Copy wsZiel.Range("E" & EinfRowZiel).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True wsBericht.Range("B8:B18").Copy wsZiel.Range("H" & EinfRowZiel).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True '..... ActiveWorkbook.Close Dateiname = Dir() Loop Application.ScreenUpdating = True End Sub

Sub DatenInWochenberichtKopieren() 'Variablen deklarieren Dim Pfad As String Dim Dateiname As String Dim arrSource As Variant Dim arrData(1 To 1, 1 To 127) As Variant Dim wbSource As Workbook Dim i As Long, j As Long, k As Long, l As Long, z As Long 'Pfad zum Ordner mit den Quelldateien angeben Pfad = "C:\Pfad\zum\Ordner\mit\Quelldateien\" 'Erste Datei im Ordner auswählen Dateiname = Dir(Pfad & "*.xlsx") 'Loop über alle Dateien im Ordner Do While Dateiname > "" 'Quelldatei öffnen Set wbSource = Workbooks.Open(Pfad & Dateiname) arrSource = wbSource.Sheets("Wochenbericht").Range("A1:H59").Value arrData(1, 1) = arrSource(3, 2) arrData(1, 2) = arrSource(4, 2) arrData(1, 3) = arrSource(5, 2) arrData(1, 4) = arrSource(6, 2) arrData(1, 5) = arrSource(4, 5) arrData(1, 6) = arrSource(5, 5) arrData(1, 7) = arrSource(6, 5) For j = 1 To 4 For k = 1 To 3 For l = 1 To 10 arrData(1, 30 * j + 10 * k + l - 33) = arrSource(13 * j - 5 + l, 3 * k - 1) Next Next Next z = z + 1 'ggf. den Bereich vorher löschen 'oder, falls die Daten ergänzt werden sollen, 'die erste freie Zeile hier ermitteln 'Daten von Quelldatei in Zieldatei kopieren ThisWorkbook.Sheets("t").Cells(z + 1, 1).Resize(1, 127).Value = arrData 'Quelldatei schließen Workbooks(Dateiname).Close False 'Nächste Datei im Ordner auswählen Dateiname = Dir Loop End Sub

Sub DatenInWochenberichtKopieren() Dim Dateiname As String Dim wsZiel As Worksheet Dim R As Range 'R wie Row Dim Map Const cPfad = "C:\Pfad\zum\Ordner\mit\Quelldateien\" 'Pfad zum Ordner mit den Quelldateien angeben Set wsZiel = ThisWorkbook.Sheets("data") 'Zielblatt definieren 'init Dateiname = Dir(Pfad & "*.xlsx") 'Loop Do While Dateiname > "" With Workbooks.Open(cPfad & Dateiname).Sheets(1) Set R = wsZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow For Each Map In Split("A1:D1|B3:B6 E1:G1|E4:E6 H1:R1|B8:B18 EJ1|B59") '-Hier kommen die Einträge (immer auf x1:y1, da relativer Bezug) Intersect(R, wsZiel.Range(Split(Map, "|")(0))) = Application.Transpose(.Range(Split(Map, "|")(1))) Next .Parent.Close 'Quelldatei schließen End With 'Nächste Datei im Ordner auswählen Dateiname = Dir Loop End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread