suche ein Macro zum Splitten von großen Datenmengen in einzelne Dateien

Hallo Claus,

funktioniert echt super - vielen Dank

Darf ich noch eine Frage stellen: in der Ursprungsdatei befindet sich noch ein 2. bzw. 3. Datenblatt - allerdings nur mit Informationen bzw. Werten für Drop-Down-Listen (auch dynamisch) - Tabelle2 bzw. Tabelle3

Iste es möglich, auch diese anderen Datenblätter mit in den "Splitt" aufzunehmen ?

Bin leider ein totaler Laie was Macros angeht ....

VD & VG

Monika

Hallo Claus,

in der Regel heißen sie immer Tabelle2 und/oder Tabelle3 - mehr Tabellenblätter wird es nicht geben

... den zweiten Punkt verstehen ich jetzt leider nicht .... sorry ...

Ich könnte dir aber eine meiner Dateien zur Verfügung stellen, kann sie hier aber nicht hochladen

VD & VG

Monika

Hallo Monika,

dann probiere mal:

Sub Splitten()

Dim myDic As Object

Dim LRow As Long, i As Long

Dim varBezirk As Variant, varTmp As Variant'Hier Pfad anpassen

Const myPath = "C:\Users\Dein_Name\Desktop\"

With Application

   .ScreenUpdating = False

   .DisplayAlerts = False

End With

On Error GoTo CleanUp'Hier Tabellenname anpassen

With Sheets("Tabelle1")

   LRow = .Cells(.Rows.Count, "A").End(xlUp).Row

   varTmp = .Range("A2:A" & LRow)

   Set myDic = CreateObject("Scripting.Dictionary")

   For i = LBound(varTmp) To UBound(varTmp)

      myDic(varTmp(i, 1)) = varTmp(i, 1)

   Next

   varBezirk = myDic.items

   For i = LBound(varBezirk) To UBound(varBezirk)

      .UsedRange.AutoFilter Field:=1, Criteria1:=varBezirk(i)

      Worksheets.Add after:=Sheets("Tabelle1")

      ActiveSheet.Name = "Bezirk_" & varBezirk(i)

      .UsedRange.Copy ActiveSheet.Range("A1")

      If Sheets.Count = 3 Then

         Sheets(Array("Bezirk_" & varBezirk(i), "Tabelle2")).Copy

      Else

         Sheets(Array("Bezirk_" & varBezirk(i), "Tabelle2", "Tabelle3")).Copy

      End If

      ActiveWorkbook.SaveAs myPath & "Bezirk_" & varBezirk(i) & ".xlsx"

      ActiveWorkbook.Close

      Sheets("Bezirk_" & varBezirk(i)).Delete

   Next

   .AutoFilterMode = False

End With

CleanUp:

With Application

   .ScreenUpdating = True

   .DisplayAlerts = True

End With

End Sub

Du kannst hier nichts direkt hochladen. Wenn du eine Mappe zur Verfügung stellen möchtest, musst du sie bei einem Filehoster wie DropBox oder in eine Cloud wie OneDrive hochladen und hier den Link zur Datei posten.

Claus

Hallo Monika,

probiere mal:

Sub Splitten()

Dim myDic As Object

Dim LRow As Long, i As Long

Dim varBezirk As Variant, varTmp As Variant
'Hier Pfad anpassen

Const myPath = "C:\Users\Dein_Name\Desktop\"Application.ScreenUpdating = False
'Hier Tabellenname anpassen

With Sheets("Tabelle1")

   LRow = .Cells(.Rows.Count, "A").End(xlUp).Row

   varTmp = .Range("A2:A" & LRow)

   Set myDic = CreateObject("Scripting.Dictionary")

   For i = LBound(varTmp) To UBound(varTmp)

      myDic(varTmp(i, 1)) = varTmp(i, 1)

   Next

   varBezirk = myDic.items

   For i = LBound(varBezirk) To UBound(varBezirk)

      .UsedRange.AutoFilter Field:=1, Criteria1:=varBezirk(i)

      Worksheets.Add after:=Sheets("Tabelle1")

      ActiveSheet.Name = "Bezirk_" & varBezirk(i)

      .UsedRange.Copy ActiveSheet.Range("A1")

      ActiveSheet.Move

      ActiveWorkbook.SaveAs myPath & "Bezirk_" & varBezirk(i) & ".xlsx"

      ActiveWorkbook.Close

   Next

   .AutoFilterMode = False

End With

Application.ScreenUpdating = True

End Sub

Claus

Hallo Claus,

super vielen lieben Dank, dass klappt jetzt ganz hervorragend !

VD & VG

Monika