Datei zerlegen - schnelle Lösung
06.12.2012 20:08:58
xxx999
Ich brauche Hilfe für folgende Probleme:
Aufgabe: 1 Excel-Datei (hat insgesammt 4 Sheets) nach Spalte A in Sheet 1 in mehrere Dateien zerlegen (am Ende ca. 500-600 Dateien) U.G. Makro erfüllt die Aufgabe einwandfrei.
2 Probleme müsste innerhalb diese Makro noch gelöst werden:
1) Sheet 2,3 und 4 müsste in den oben erzeugte Dateien auch als Sheet 2,3 und 4 ohne Veränderung kopiert werden (Namen der einzelne Sheets sollen auch nicht geändert werden)(Ergebnis sollte sein: ca. 500-600 Dateien a 4 Sheets)
2) Alle Formatierung aus der Original-Datei soll in die einzelne Dateien übernommen werden (Spaltenbreite, Zeilenumbrüche, Formels, Blattschutz... usw.)
Sub Zerlegen_Speichern()
Pfad = "C:\Lieferanten\" 'Speicherort festlegen (Ordner)
Dim rng As Range, rngCur As Range
Dim lngRow As Long
Application.ScreenUpdating = False
Set rngCur = Range("A1").CurrentRegion
rngCur.Sort _
key1:=Range("A2"), _
order1:=xlAscending, _
Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngCur.Cells(lngRow, 1))
If rngCur.Cells(lngRow, 1) rngCur.Cells(lngRow - 1, 1) Then
rngCur.AutoFilter _
field:=1, _
Criteria1:=rngCur.Cells(lngRow, 1)
Set rng = rngCur.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
ws = rngCur.Cells(lngRow, 1)
ActiveSheet.Name = ws
rng.Copy Range("A1")
Lieferant = Sheets(2).Name 'hier wird der Dateiname festgelegt
ActiveSheet.Copy
ActiveSheet.SaveAs Filename:=Pfad & Lieferant 'Datei in Pfad speichern
ActiveWorkbook.Close
Application.DisplayAlerts = False
ActiveSheet.Delete 'Blatt löschen
Application.DisplayAlerts = True
End If
lngRow = lngRow + 1
Loop
Worksheets(1).Select
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = False
End Sub
Vielen Dank.
xxx999