Macro that transposes information

Option Explicit
Option Base 1


Sub obtener()


Dim r As Range, fr%, cr%
    Set r = Range("A1").CurrentRegion


Dim z As Object, zs$, M(1 To 5)
    Set z = CreateObject("scripting.dictionary")
Dim K As New Collection, ks$, kn%




On Error Resume Next 'para la K
    For fr = 1 To r.Rows.Count
        
        zs = r(fr, 1).Row


        If r(fr, 1) Like "PO=*" Then


            ks = ""
            For cr = 2 To 4
                ks = ks & r(fr + cr, 1)
            Next
            K.Add ks, ks




            If K.Count > kn Then
                kn = K.Count
            Else
                fr = fr + 5
                GoTo sigue
            End If


        
            M(1) = r(fr, 1)
            fr = fr + 1
            M(2) = r(fr, 1)
            fr = fr + 1
            M(3) = r(fr, 1)
            fr = fr + 1
            M(4) = r(fr, 1)
            fr = fr + 1
            M(5) = r(fr, 1)
            z.Add zs, M()
        Else
            ks = ""
            For cr = 0 To 2
                ks = ks & r(fr + cr, 1)
            Next
            K.Add ks, ks


            If K.Count > kn Then
                kn = K.Count
            Else
                fr = fr + 2
                GoTo sigue
            End If


'            zs = r(fr, 1).Row
            M(1) = Empty
            M(2) = Empty
            M(3) = r(fr, 1)
            fr = fr + 1
            M(4) = r(fr, 1)
            fr = fr + 1
            M(5) = r(fr, 1)
            z.Add zs, M()
        End If
sigue:
    Next


    Columns("C:J").ClearContents
    Range("C2").Resize(z.Count, 5) = Application.Index(z.items, 0, 0)
End Sub