Microsoft Excel

Herbers Excel/VBA-Archiv

VBA jede Zeile in neue Datei kopieren

Betrifft: VBA jede Zeile in neue Datei kopieren von: wossawog
Geschrieben am: 08.04.2021 19:19:43

Hallo zusammen,


leider bin ich ein ziemlicher noob in VBA und bräuchte eure Hilfe. Ich habe eine Datei mit Mitarbeiterdaten. In A1:X1 ist der Header, darunter stehen die Daten. Also pro Zeile ein neuer Mitarbeiter. Nun habe ich im gleichen Ordner eine andere Datei die für eine Befragung an die Mitarbeiter geschickt werden soll. Ich brauche jetzt ein VBA Makro, dass A2:X2 kopiert, die andere Datei öffnet und dann dort in A1:X1 einfügt. Dann soll diese Datei gespeichert werden und den Namen des Werts in Zelle X1 haben. Das selbe soll dann in einer Schleife für die nächsten Zeilen gemacht werden.

Ich habe einen Code geschrieben der es manuell für die ersten beiden Zeilen macht, aber für _ einen Loop bin ich zu blöd.

Sub Daten_Kopieren()
    Dim wbStart, wbZiel As Workbook
    Dim strPath As String
    Dim cell As Range
    strPath = ActiveWorkbook.Path
    Application.ScreenUpdating = False
   
    Set wbStart = ActiveWorkbook
    Set wbZiel = Workbooks.Open("C:\Users\Tool\Survey.xlsx")
    wbStart.Sheets("Finale_Liste").Range("A2:X2").Copy Destination:=wbZiel.Sheets("Arbeitsblatt" _
).Range("A1:X1")
    wbZiel.SaveAs Filename:=strPath & "\" & Range("X1")
    wbStart.Sheets("Finale_Liste").Range("A3:X3").Copy Destination:=wbZiel.Sheets("Arbeitsblatt" _
).Range("A1:X1")
    wbZiel.SaveAs Filename:=strPath & "\" & Range("X1")
   
    Application.ScreenUpdating = True
    MsgBox "Fertig"
   
End Sub


Da die beiden Dateien zwar im gleichen Ordner bleiben, der Pfad sich aber ändern wird, bräuchte ich auch eine andere möglichkeit den Pfad von wbZiel zu definieren.

Ich bin mittlerweile echt am verzweifeln, falls mir jemand helfen kann wäre ich super dankbar.


Prost!

Betrifft: AW: VBA jede Zeile in neue Datei kopieren
von: Werner
Geschrieben am: 08.04.2021 20:38:49

Hallo,

Teste mal:
  • Sub Daten_Kopieren()
    Dim wbZiel As Workbook, strPath As String, i As Long
    
    strPath = ActiveWorkbook.Path
    Application.ScreenUpdating = False
    
     Set wbZiel = Workbooks.Open("C:\Users\Tool\Survey.xlsx")
     
    With ThisWorkbook.Worksheets("Finale_Liste")
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            .Cells(i, "A").Resize(, 24).Copy _
            wbZiel.Sheets("Arbeitsblatt").Range("A1")
            wbZiel.SaveAs Filename:=strPath & "\" & .Cells(i, "X")
        Next i
    End With
    
    Set wbZiel = Nothing
    MsgBox "Fertig"
    End Sub


  • Gruß Werner