Dim r1, r2  ' текущее значение
Dim a1, a2  ' номер строки
Dim p1, p2  ' прежнее значение

Dim stroki As Range, rng As Range


Sub Макрос1()

    Set stroki = ThisWorkbook.Worksheets("исходные данные").Range("A1:A30")
    
    For Each rng In stroki
        r3 = Mid(rng.Value,  1 ,  5 )
        If p3 <> r3 Then
            'MsgBox "a2: " & a2
            Group12 (a3)
            p3 = r3
            a3 = rng.Row
        End If
        
        r2 = Mid(rng.Value,  1 ,  3 )
        If p2 <> r2 Then
            'MsgBox "a2: " & a2
            Group12 (a2)
            p2 = r2
            a2 = rng.Row
        End If
        
        r1 = Mid(rng.Value,  1 ,  1 )
        If p1 <> r1 Then
        'MsgBox "a1: " & a1
            Group12 (a1)
            p1 = r1
            a1 = rng.Row
        End If
    
    Next
    
End Sub


Sub Group12(ByVal a)
    If (IsEmpty(a) = False) And ((a +  1 ) < (rng.Row -  1 )) Then
        stroki.Range((a +  1 ) & ":" & (rng.Row -  1 )).Group
    End If
End Sub