Microsoft Excel

Herbers Excel/VBA-Archiv

Excel Tabelle aufteilen und einzeln sichern

Betrifft: Excel Tabelle aufteilen und einzeln sichern von: Paul-Werner Neiss
Geschrieben am: 12.11.2014 17:57:40

Hallo Excel-Gurus,
ich habe ein Problem mit einer Riesen-Datei, die ich sortieren und in einzelne kleine Dateien splitten und speichern muss.
Die Datei enthält ca. 300000 Einträge, die in ca. 50000 Einzeldateien zerlegt und gesichert werden soll.
Ich hänge einen Auszug dieser Datei unter https://www.herber.de/bbs/user/93721.xlsx an. In der Spalte A ist ein eindeutiger Indikator, zum Beispiel D000001. In der Zeile 1 ist eine Überschrift, welche in jede Datei kopiert werden soll.
Die Aufgabe besteht nun darin, alle Zeilen, die den gleichen Indikator in Spalte A haben, mit der Überschrift in Zeile 1 in eine neue Excel-Datei zu sortieren und mit dem Indikator als Dateiname an einen vorgegeben Ort der Festplatte zu speichern.
Ich hoffe, ich konnte mein Problemchen schlüssig erläutern und hoffe ebenfalls auf Eure Ideen.
Vielen Dank im Voraus
Paul

  

Betrifft: AW: Excel Tabelle aufteilen und einzeln sichern von: Martin S.
Geschrieben am: 13.11.2014 07:16:30

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


  

Betrifft: AW: Excel Tabelle aufteilen und einzeln sichern von: Paul-Werner Neiss
Geschrieben am: 13.11.2014 10:28:56

Hallo Martin,
herzlichen Dank für Deinen schnellen Lösungsvorschlag.
Ich habe das Makro ausgeführt und stoße auf einen Fehler 400? Die Datei wird getrennt, allerdings nicht gesichert. Ich nehme an, daß ich irgendeinen Fehler mache.
So, wie Du es beschreibst, könnte ich das durchaus einsetzen, würdest Du bitte nochmals die Datei anschauen und prüfen, welchen Fehler ich gemacht habe?
Ich habe die Datei mit Makro unter https://www.herber.de/bbs/user/93738.xlsm geladen.
Vielen Dank im Voraus, viele Grüße
Paul


  

Betrifft: AW: Excel Tabelle aufteilen und einzeln sichern von: Martin S.
Geschrieben am: 13.11.2014 10:58:35

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


  

Betrifft: Wo bleibt die Rückmeldung? von: Martin S.
Geschrieben am: 15.11.2014 12:42:48

Hallo Paul,

eine Rückmeldung ist doch das Mindeste?! Klappt das Makro nun wie gewünscht?

Martin


  

Betrifft: AW: Wo bleibt die Rückmeldung? von: Paul-Werner Neiss
Geschrieben am: 17.11.2014 10:02:30

Hallo Martin,
sorry, ich bin leider noch nicht zum Testen gekommen,ich werde das heute nachholen und Dir das Ergebnis mitteilen.
Erst einmal vielen Dank für Deine Unterstützung.

Payul


  

Betrifft: AW: Wo bleibt die Rückmeldung? von: Paul-Werner Neiss
Geschrieben am: 17.11.2014 16:34:08

Hallo Martin,
irgendwie sehe ich meine letzte Antwort nicht mehr.
Ich habe das nochmals getestet, wobei ich festgestellt habe, daß der von Dir genannte Code ja bereits im Makro enthalten ist? Ich habe also nochmals ein paar Varianten getestet, allerdings immer mit dem gleichen Fehler 400.
Gibt es eine Möglichkeit, mir Deine Excel 2003 zu schicken?

Danke und Grüße

Paul


 

Beiträge aus den Excel-Beispielen zum Thema "Excel Tabelle aufteilen und einzeln sichern"