Sub Zellwerte_ausSpalteA_in_Xer_Spalten_transponieren() 
  'die Zellwerte aus Spalte_A werden in Spalten zu je X Reihen verteilt 
    
  reihen_anzahl = 6   'für eine verteilung von X (hier 6) Reihen pro Spalte 
  zellen_anzahl = Worksheets(1).UsedRange.Rows.Count 
  r2 = 1 
  c = 2     'beim Transponieren ab Spalte 2 beginnen 
  letzter_zellwert = 0 
  Antwort = MsgBox("In der Tabelle sind " & zellen_anzahl & " Reihen enthalten!" & vbCr & vbCr _ 
    & "Werte umsortieren in (maximal) " & (zellen_anzahl + reihen_anzahl - 1) \ reihen_anzahl & " Spalten?", vbOKCancel, "Makro ausführen?") 
  If Antwort = vbCancel Then Exit Sub 
   
  For r1 = 1 To zellen_anzahl 
    If r2 = 1 And (Worksheets(1).Cells(r1, 1).Value = "" Or Worksheets(1).Cells(r1, 1).Value = 0) Then 
      'leeren/Null-Wert niemals nicht in Reihe 1 übertragen! 
    Else 
      If Worksheets(1).Cells(r1, 1).Value = letzter_zellwert Then 
        'alles paletti 
        Worksheets(1).Cells(r2, c).Value = Worksheets(1).Cells(r1, 1).Value 
        'Worksheets(1).Cells(r1, 1).ClearContents  'alte Zellwerte löschen 
      Else  ' neuen Zellwert in nächste Spalte übertragen 
        letzter_zellwert = Worksheets(1).Cells(r1, 1).Value 
        If r2 = 1 Then 
          'auch alles paletti 
          Worksheets(1).Cells(r2, c).Value = Worksheets(1).Cells(r1, 1).Value 
          'Worksheets(1).Cells(r1, 1).ClearContents  'alte Zellwerte löschen 
        Else 
          'Zellen in den neuen Spalten mit Nullern auffüllen 
          For r3 = r2 To reihen_anzahl 
            Worksheets(1).Cells(r3, c).Value = 0 
          Next r3 
          c = c + 1 
          r2 = 0 
        End If 
      End If 
      If r2 = reihen_anzahl Then 
        c = c + 1 'nächste Spalte befüllen 
        r2 = 1 
      Else 
        r2 = r2 + 1 
      End If 
    End If 
  Next r1 
End Sub