Datei aufsplitten in Dateien mit gleichem Wert in Spalte A
20.12.2023 14:25:41
Kedi0815
hoffentlich könnt ihr mir helfen!
In meiner Exceldatei stehen in Zeile 1 Überschriften und in Spalte A Zahlen, die als Text formatiert sind und mehrfach vorkommen können.
Ich suche ein Makro, dass jeweils die Überschrift und alle Zeilen von Spalte A bis AI, die den gleichen Wert in Spalte A enthalten, in eine neue Datei kopiert und mit der Zahl in Spalte A als Dateinamen im Pfad C:\xxx speichert.
Das mit KI-Hilfe erzeugte Makro legt zwar brav die Dateien an, leider sind die aber alle leer und ich kann den Fehler nicht finden.
Vielen Dank im Voraus für eure Hilfe!
Gruß Kedi
Sub CopyRowsToNewFile()
Dim lastRow As Long
Dim i As Long
Dim dict As Object
Dim key As Variant
Dim cell As Range
Dim newBook As Workbook
Dim newSheet As Worksheet
Dim fileName As String
'Create a dictionary to store the unique values in column A
Set dict = CreateObject("Scripting.Dictionary")
'Get the last row of data in column A
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Loop through the data and add the unique values to the dictionary
For i = 2 To lastRow
If Not dict.exists(Cells(i, "A").Value) Then
dict.Add Cells(i, "A").Value, i
End If
Next i
'Loop through the dictionary and copy the rows to a new file
For Each key In dict.keys
'Create a new workbook and worksheet
Set newBook = Workbooks.Add
Set newSheet = newBook.Sheets(1)
'Copy the rows with the matching value in column A
For Each cell In Range("A2:A" & lastRow)
If cell.Value = key Then
Range("A" & cell.Row & ":AI" & cell.Row).Copy newSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next cell
'Save the new file with the value from column A as the filename
fileName = "C:\xxx\" & key & ".xlsx"
newBook.SaveAs fileName
'Close the new file
newBook.Close False
Next key
End Sub