Hi Matthias., für den Fall das du noch Hilfe brauchst:

Diese Demo geht davon aus, das die MatNr-Quelldaten im Tabellenblatt 'Tabelle1' Spalte C liegen

und die MatNr-Listen ins Tabellenblatt 'Tabelle2' geschrieben werden sollen.

Weiterhin:

1. Ich sortiere hierbei die Liste nicht (ist aber möglich, siehe auskommentierte Zeile).
2. Die MatNr'n werden nicht aus der Quelle entfernt, nachdem sie ins Ziel übertragen wurden (ließe sich aber noch ändern).
3. Das Makro arbeit solange bis keine einzige MatNr mehr übrig bleibt. Dabei können also dem Ende zu auch Listen entstehen, die weniger als 48 Elemente beinhalten.

Hier und da hab ich als Hilfestellung kommentiert. Die Debug-Zeilen kann man bei Bedarf auskommentieren (oder ganz entfernen).

Option Explicit

Public Sub Demo()
  
  Dim wksSrc As Excel.Worksheet
  Dim wksDst As Excel.Worksheet
  Dim rngTable As Excel.Range
  Dim lngMatNrId As Long
  
  'Quelle
  Set wksSrc = Worksheets("Tabelle1")
  'Ziel
  Set wksDst = Worksheets("Tabelle2")
  
  Set rngTable = wksSrc.Range("C1").CurrentRegion
  lngMatNrId = 1 + wksSrc.Range("C1").Column - rngTable.Column
  'sortiere Spalte 'MatNr' aufsteigend
'  Call rngTable.Sort(Key1:=rngTable.Cells(lngMatNrId), Order1:=xlAscending, Header:=xlYes)
  
  Dim dicMatNrP As Scripting.Dictionary   'Pool mit einzigartigen MatNr
  Dim dicMatNrL As Scripting.Dictionary   'Liste mit bis zu X MatNr
  Dim rngMatNr  As Excel.Range
  Dim strMatNr  As String
  Dim i         As Long
  
  Set dicMatNrP = New Scripting.Dictionary
  
  For i = 2 To rngTable.Columns(lngMatNrId).Cells.Count
    Set rngMatNr = rngTable.Cells(i, lngMatNrId) '(neue) MatNr
    strMatNr = CStr(rngMatNr) 'MatNr als String/Key
    'ggf. neue MatNr anlegen
    If Not dicMatNrP.Exists(strMatNr) Then Call dicMatNrP.Add(strMatNr, New VBA.Collection)
    'lege MatNr-SubItem an
    Call dicMatNrP(strMatNr).Add(rngMatNr)
  Next
  
  Do While dicMatNrP.Count > 0
    
    Set dicMatNrL = New Scripting.Dictionary
    i = 0
    
    Do While dicMatNrP.Count > 0 And i < dicMatNrP.Count And dicMatNrL.Count < 48
      
      strMatNr = dicMatNrP.Keys(i)
      Set rngMatNr = dicMatNrP(strMatNr).Item(1) 'oberes/erstes SubItem
      Debug.Print "## entnehme SubItem von MatNr('"; CStr(rngMatNr); "') < Range('"; rngMatNr.Address(0, 0); "')"
      Call dicMatNrP(strMatNr).Remove(1) 'entferne dieses MatNr-SubItem ...
      Call dicMatNrL.Add(CStr(strMatNr), rngMatNr) '... und füge es der Ausgabe-Liste hinzu
      
      If dicMatNrP(strMatNr).Count = 0 Then
        Debug.Print "## -> keine weiteren SubItem's für MatNr('"; CStr(rngMatNr); "') vorhanden -> entferne Eintrag -> "; CStr(dicMatNrP.Count - 1); " MatNr verbleibend)"
        Call dicMatNrP.Remove(strMatNr)
      Else
        i = i + 1
      End If
      
    Loop
    
    Debug.Print String$(65, "#")
    Debug.Print "## MatNr-Liste enthält "; CStr(dicMatNrL.Count); " Elemente"
    Debug.Print "## es sind noch "; CStr(dicMatNrP.Count); " MatNr vorrätig"
    
    'Beispiel für Ausgabe (Listen werden spaltenweise geschrieben):
    With wksDst.Range("A1")
      If Trim$(.Value) <> "" Then
        If Trim$(.Offset(, 1).Value) <> "" Then
        'in erste freie Spalte schreiben
          .End(xlToRight).Offset(, 1).Resize(dicMatNrL.Count).Value = WorksheetFunction.Transpose(dicMatNrL.Items)
        Else
        'in zweite Spalte schreiben
          .Offset(, 1).Resize(dicMatNrL.Count).Value = WorksheetFunction.Transpose(dicMatNrL.Items)
        End If
      Else
      'in erste Spalte schreiben
        .Resize(dicMatNrL.Count).Value = WorksheetFunction.Transpose(dicMatNrL.Items)
      End If
    End With
    
  Loop
  
  Debug.Print ">> FERTIG <<"
  
End Sub

Grüße

Trägheit