Excel Tabelle aufteilen und einzeln sichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Paul,
ich habe versucht deinen Wunsch umzusetzen. Du musst dich allerdings darauf einstellen, dass der Vorgang eine ganze Weile dauern wird. Im Augenblick werden die Dateien in dem Verzeichnis gespeichert, in dem sich deine "Riesen-Datei" befindet. Du musst einfach nur "ThisWorkbook.Path" durch ein Verzeichnis deiner Wahl ersetzen, falls die Dateien woanders gespeichert werden sollen.
Hoffentlich funktioniert das Makro entsprechend deiner Vorstellung:

Sub IndikatorenExportieren()
Dim dicIdentNo As Object
Dim strIdentNo As String
Dim arrIdentNo As Variant
Dim lngLastRow As Long, i As Long
Set dicIdentNo = CreateObject("Scripting.Dictionary")
'AutoFilter in Spalte A einrichten
Columns("A:A").AutoFilter
If Not ActiveSheet.AutoFilterMode Then
Columns("A:A").AutoFilter
End If
'Letzte Zeile ermitteln
lngLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Alle Indikator ermitteln
With dicIdentNo
For i = 2 To lngLastRow
strIdentNo = Trim(Cells(i, 1).Text)
If Not .Exists(strIdentNo) Then
.Add strIdentNo, 0
End If
Next i
'Alle Indikatoren in Array übertragen
arrIdentNo = .keys
'Jeden Indikator filtern und in neuer Arbeitsmappe speichern
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 0 To .Count - 1
Selection.AutoFilter Field:=1, Criteria1:=arrIdentNo(i)
Cells.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
ActiveSheet.Paste
Selection.Columns.AutoFit
Range("A1").Select
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "/" & arrIdentNo(i) & ".xlsx"
.Close
End With
Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End With
End Sub

Viele Grüße
Martin

Hallo Paul,
du hast keinen Fehler gemacht. Ich habe das Makro mit Excel 2003 geschrieben, damals gab es das xlsx-Dateiformat noch nicht. Ich dachte, dass ich einfach nur ein "x" an die alte Dateiendung "xls" hängen muss, aber anscheinend geht das nicht so einfach. Wenn dir das xls-Format ausreicht, das verwende folgenden Code zum Speichern und Schließen der neu erstellten Arbeitsmappe:

            With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "/" & arrIdentNo(i) & ".xls"
.Close
End With

Wenn du die Dateien im xlsx-Format speichern möchtest, dann verwende folgenden Code:


With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "/" & arrIdentNo(i) & ".xlsx", FileFormat:=51
.Close
End With

Die zweite Variante konnte ich wegen meiner alten Excel 2003-Version nicht testen.
Viele Grüße
Martin

Beliebteste Forumthreads (12 Monate)

Excel Tabelle aufteilen und einzeln sichern

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

83 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel Tabelle aufteilen und einzeln sichern

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

83 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread