Office: 4 Arbeitsblätter exportieren nach Kriterium VBA

Hallo zusammen,

aus einer Arbeitsmappe sollen 4 Arbeitsblätter ("Name1", "Name2" etc.) anhand des Bereich in Spalte A in separat zu erstellende Arbeitsmappen je Bereich exportiert werden, sie sollen jeweils die gleiche Bezeichnung des Bereichs erhalten , also z. B. "1", "2" etc. Ich habe ein Makro gefunden, was leider nur das 1. Arbeitsblatt exportiert und nicht alle 4. Mir ist es leider nicht gelungen es anzupassen, kenne mich mit VBA auch nicht wirklich gut aus.

Hat jemand eine Idee, wie das Makro aussehen müsste?

Eine Muster der Basis Arbeitsmappe sowie als Bsp. das gewünschte Ergebnis für den Bereich 1 ist beigefügt.

Viele Grüße
Tom

 

Hallo,

kann keiner helfen? Ich habe mich noch ein paar mal damit beschäftigt, aber ich bekomme es nicht hin.

Ansonsten muss ich das doch weiter alles per Hand kopieren, aber ein Makro hätte den Aufwand auf ein Minimum reduziert.

Viele Grüße
Tom

 

Hallo Tom,

Deine Beschreibung und Code ist mir nicht klar.
Den Datensatz aus der "XLSX" Datei findet man nicht in der "XLSM" Datei, mir ist also nicht klar wie der Satz in der "XLSX" Datei erstellt wurde?
Möchtest Du für jeden Datensatz in der XLSM Datei eine Datei haben? Welcher Dateiname? Spalte F?
nur "Name1"?

 

Hallo Tom,

erst wird sich beschwert das keine Antwort kommt. Dann kommt keine Antwort auf die Antwort.
Ich vermute das kommt auch erst in 3 Tagen. Ich bin dann raus, nach dieser Zeit ist der Beitrag für mich nicht mehr aktuell.
Viel Erfolg.
Meinen Beitrag umgestzt.

Code:

Option Explicit

Sub Kopie()
    '**************************************************
    '* H. Ziplies                                     *
    '* 28.12.22                                       *
    '* erstellt von HajoZiplies@WEB.de                *
    '* http://Hajo-Excel.de                           *
    '**************************************************
    Dim Loletzte As Long
    Dim LoI As Long
    Dim WsTabelle As Worksheet
    ' Schleife über alle Tabelle
    Application.DisplayAlerts = False
    For Each WsTabelle In Worksheets
        With WsTabelle
            Loletzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            ' Schleife über Tabelle
            For LoI = 2 To Loletzte
                Workbooks.Add
                .Rows(1).Copy Rows(1)
                .Rows(LoI).Copy Rows(2)
                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("F2") & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                ActiveWorkbook.Close
            Next LoI
        End With
    Next WsTabelle
    Application.DisplayAlerts = True
End Sub

 

Hallo Hajo,

bitte entschuldige, ich hatte eigentlich eingestellt, dass ich per E Mail benachrichtigt werde, wenn eine Antwort kommt, hatte aber nichts bekommen und gerade erst gesehen dass du geantwortet hast. Falls du trotzdem weiter helfen würdest, fände ich das toll.

Das Makro aus der "XLM" Datei habe ich unten aufgeführt. Hier wird leider immer nur 1 Tabellenblatt und nicht alle 4 aufgeteilt. Das Ergebnis soll eigentlich so sein, als ob in der "XLM" Datei alle 4 Arbeitsblätter jeweils nach Spalte A ("Bereich") gefiltert und jeweils als neue Arbeitsmappe abgespeichert werden, also "1", "2", "3" etc. Die "XLSX" Beispieldatei sollte das Wunschergebnis für den Bereich 1 mit allen 4 Arbeitsblättern darstellen.

Viele Grüße
Tom

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

 

Gut Du möchtest unbeding Dein Makro ändern, da ich damit nich klar komme bist Du selber dran.
Ich bin dann raus. Mein Makro hat Dir nicht gefallen. Das meiner Meinung nach Deine Aufgabe löst für die Datei. In der nichts gefiltert war und darum nicht berücksichtigt.

Gruß Hajo

 

Dein Makro liefert doch ganz andere Ergebnisse, es wird für jeden Mitarbeiter eine eigene Arbeitsmappe erzeugt und nicht für jeden Bereich mit allen Arbeitsblättern. Ich hatte gehofft, dass jemand mir Hilfe bei der Umstellung meines Makros geben könnte, dass ja grds. richtige Ergebnisse liefert, aber nur für 1 Arbeitsmappe und nicht alle 4 je Bereich.

Gruß
Tom