Sub EXPORT()
Dim strPath As String, cell As Range
strPath = ActiveWorkbook.Path
Dim newPath As String
Application.ScreenUpdating = False
newPath = strPath & "\" & Format(Date, "YYYY_MM_DD")
MkDir newPath
With ActiveSheet
For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
.Range("1:1," & cell.Row & ":" & cell.Row).Copy
With Workbooks.Add
.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=False
.SaveAs newPath & "\" & cell.Value, FileFormat:=xlText
.Close
End With
Next
End With
Application.ScreenUpdating = True
'MsgBox "Fertig exportiert"
Shell "explorer.exe """ & newPath & """", vbNormalFocus
End Sub