Transponieren Spalte auf Zeile bei bestimmten Zellinhalt

[Paperstar]

Hallo zusammen,

ich hoffe. ihr könnt mir helfen.
Ich habe eine Excel-Tabelle mit einem Sheet.
In dem Sheet ist nur eine Spalte mit Werten, siehe das Beispiel:

In Spalte A1 sind folgende Beispielwerte

1
2
3
1
2
3
1
2
3​

Nun suche ich ein Makro, das folgendes macht.
Es soll in der Spalte A immer nach dem Wert = 1 suchen und dann alle folgenden Wert bis zur nächste Zelle mit dem Wert 1 in ein neues Sheet an die Stelle A1 Transponieren.

1 2 3
1 2 3
1 2 3​

Das soll so lange laufen, bis die letzte Zeile der Spalte mit einem Blank erreicht wird.

In der Quellspalte können unterschiedlich viele Werte sein, die aber immer mit dem Wert 1 beginnen.
Vielen Dank für eure Hilfe.

 

[Mr. Snoot]

Sub transponieren()

Dim iEnde As Integer   [COLOR="seagreen"]'Ende von Spalte A[/COLOR]
Dim i As Integer       [COLOR="seagreen"]'Zeilenzähler[/COLOR]
Dim k As Integer       [COLOR="seagreen"]'Spaltenzähler[/COLOR]
Dim iMerken As Integer [COLOR="seagreen"]'Zeile der aktuellen '1' merken[/COLOR]

iEnde = Sheets("Tabelle1").UsedRange.Rows.Count [COLOR="seagreen"]'letzte Zeile ermitteln[/COLOR]

For i = 1 To iEnde             [COLOR="SeaGreen"]'von Zeile 1 bis iEnde[/COLOR]
    If Range("A" & i) = 1 Then [COLOR="SeaGreen"]'prüfen ob Zelle = 1[/COLOR]
        iMerken = i            [COLOR="seagreen"]'Zeile merken[/COLOR]
        k = 2                  [COLOR="seagreen"]'erste Spalte = Spalte 2 (B)[/COLOR]
        Do While Range("A" & i + 1) <> 1 And Range("A" & i + 1) <> "" [COLOR="seagreen"]'Schleife solange die nächste Zeile nicht '1' und nicht 'leer'[/COLOR]
            Cells(i, k) = Range("A" & iMerken + 1)                    [COLOR="seagreen"]'Zelle in Zeile i und Spalte k = Wert aus Spalte A und eine Zelle unter aktueller '1'[/COLOR]
            Range("A" & iMerken + 1).EntireRow.Delete                 [COLOR="seagreen"]'Zeile mit kopierter Zelle löschen[/COLOR]
            k = k + 1                                                 [COLOR="seagreen"]'Spalte zum Einfügen um 1 erhöhen[/COLOR]
        Loop
    End If
Next i

End Sub

 

[Paperstar]

Guten Morgen und thx Mr.Snoot,

und wow ... das funzt. Werde das mal ausführlich testen.
Besten Dank.