Hi zusammen,

ich bin hier ziemlich neu im Thema und habe seit der Uni nichts mehr in VBA programmiert. Mein Problem ist Folgendes:

Ich habe eine Excel Tabelle mit mehreren tausend Zeilen, die ich gerne in mehrere Excel Listen aufteilen möchte. Bis jetzt bin ich (durch Zusammenkopieren von Codeschnipseln) so weit gekommen, dass ich die neuen Excel Listen erstellen kann, jedoch nur mit fixen Vorgaben für die Anzahl an Zeilen pro neuer Excel Liste.

Was ich jedoch möchte ist Folgendes:

In Spalte C stehen Materialnummern, die teilweise auch mehrfach vorkommen (Liste wird bereits durch das Makro nach Materialnummern sortiert). In die neuen Excel Listen sollen jetzt nicht fixe Anzahl an Zeilen geschrieben werden sondern so viele Zeilen, bis 48 verschiedene Materialnummern erreicht sind.
Das Makro müsste also die Zeilen durchgehen und dabei die Anzahl an verschiedenen Materialnummern hochzählen, bis 48 erreicht ist. Anschließend die nächsten 48 usw usw.

Der Code sieht aktuell folgendermaßen aus (ist wie gesagt zusammenkopiert und bestimmt alles andere als sinnvoll zusammengesetzt):

Option Explicit
 
Sub SplitDataSheet()
   Dim lRow As Long, lCol As Integer, BlockGroesse As Integer
   Dim AnzNullen As Byte, Nullen As String
   Dim rngZeile1 As Range, rngBlock As Range, Block As Integer
   Dim ZeBlockS As Long, ZeBlockE As Long, AnzBlocks As Integer
   Dim DstPath As String, DstName As String, DstFileName As String
   Dim wksSrc As Worksheet, rng2Copy As Range, DateiFormat As Variant
   Dim strSpalte As String  'Sortieren der Zeilen
   Dim strBereich As String 'Sortieren der Zeilen
   Dim AnzahlWerte As String 'Anzahl verschiedene Materialnummern

   
   'Folgender Abschnitt berechnet die Anzahl an Materialnummern

   Set wksSrc = ActiveSheet 'Zählen der verschiedenen Materialnummern
   Dim objDict, i As Long, AnzahlMatnr As Long    'AnzahlMatnr ist Anzahl der verschiedenen Materialnummern
   Set wksSrc = ActiveSheet
   Set objDict = CreateObject("Scripting.Dictionary")
   With wksSrc
   For i = 1 To .Cells(Rows.Count, 3).End(xlUp).Row
   If Not objDict.exists(.Cells(i, 3).Value) Then
   Call objDict.Add(.Cells(i, 3).Value, Empty)
   AnzahlMatnr = AnzahlMatnr + 1
   End If
   Next
   AnzahlMatnr = AnzahlMatnr - 1
   
   MsgBox AnzahlMatnr & " Einträge" 'Ausgabe der Anzahl an Materialien


   'Folgender Abschnitt sortiert die Zeilen nach Spalte C

   Set wksSrc = ActiveSheet  'Parameter zum Sortieren
   strBereich = "A1:AJ1048576"
   strSpalte = "C"

    'Sortieren durchführen
    Range(strBereich).Sort _
     Key1:=Range(strSpalte & "1"), Order1:=xlAscending, _
     Header:=xlYes


   lRow = Cells(Rows.Count, 1).End(xlUp).Row
   lCol = Cells(1, Columns.Count).End(xlToLeft).Column
   
   
   'Hier Anzahl der Materialien je Block eingeben
   
   BlockGroesse = 48
   
   'Hier wird das Dateiformat festgelegt, sowie die erste Zeile übersprungen
   
   Set wksSrc = ActiveSheet
   DateiFormat = xlWorkbookNormal  'Alternativ:  xlCSV,  xlTextWindows,  xlWorkbookDefault, ...
   If lRow < 2 Then Exit Sub  'Nur überschrift macht keinen Sinn ...
   On Error GoTo ErrorHandler
 
    With Application
      .DisplayAlerts = False
      .ScreenUpdating = False
   End With
   
   
   'Hier werden die Variablen für die Auswahl der Zeilen festgelegt
   
   AnzBlocks = WorksheetFunction.RoundUp((AnzahlMatnr) / BlockGroesse, 0)
   AnzNullen = Len(CStr(AnzBlocks))
   Nullen = WorksheetFunction.Rept(0, AnzNullen)
   DstPath = "C:\Users\baumann\Desktop\Auswertung Kristian\Splits"
   DstName = "_Block_"
   
   MsgBox AnzBlocks 'Ausgabe der Anzahl an Blocks

   
   
   With wksSrc
        Set rngZeile1 = .Range(.Cells(1, 1), .Cells(1, lCol))
        For Block = 1 To AnzBlocks    'was mache ich mit einem Block
        DstFileName = DstPath & DstName & Format(Block, Nullen)
        
        ZeBlockS = (Block - 1) * BlockGroesse + 2
        ZeBlockE = WorksheetFunction.Min(ZeBlockS + BlockGroesse - 1, lRow)
        
        
        Set rng2Copy = Union(rngZeile1, .Range(.Cells(ZeBlockS, 1), .Cells(ZeBlockE, lCol)))
        rng2Copy.Copy
        Workbooks.Add
                 
         With ActiveSheet
            .Paste
            .Cells(1, 1).Select
         End With
         
         
         With ActiveWorkbook
            .SaveAs Filename:=DstFileName, FileFormat:=DateiFormat
            .Close SaveChanges:=True
         
         
         End With
      
      Next Block
   End With
   

ErrorHandler:
   With Application
      .DisplayAlerts = True
      .ScreenUpdating = True
   End With
   If Err.Number = 0 Then
      MsgBox "Aufgabe erledigt!", vbInformation, "Ohne Fehler"
   Else
      MsgBox "Beendet mit Fehler Nr.: " & Err.Number & vbCrLf _
       & Err.Description & vbCrLf _
       & "Bitte prüfen Sie das Ergebnis!", vbCritical, "Fehler"
   End If
   
   
   
   End With
   End Sub
   

Wenn hierzu jemand eine Idee hat, wäre ich sehr dankbar.

Viele Grüße,
Matthias