Option Explicit
Sub Test()
Dim TDon(), TRésu(), LD As Long, C As Integer, LR As Long
TDon = ActiveSheet.[A1].CurrentRegion.Value
ReDim TRésu(1 To 5, 1 To UBound(TDon, 1))
LD = 1
Do: C = C + 1: LR = 1: TRésu(LR, C) = TDon(LD, 1)
Do:
LR = LR + 1: TRésu(LR, C) = TDon(LD, 2)
If LD >= UBound(TDon, 1) Then Exit Do
LD = LD + 1
Loop Until TDon(LD, 1) <> TRésu(1, C)
Loop Until LD = UBound(TDon, 1)
[D1].Resize(5, C).Value = TRésu
End Sub