Array resize - arranjament matriu comparant tres primers caràcters

 Sub Macro1()

Dim CantFila As Long
Dim CantCol As Long
Dim c As Single, f As Single, m As Single, n As Single
Dim Ultim As String
Dim a As Variant


m = 26
n = 1
Ultim = Left(Cells(1, 1).Value, 3)
Debug.Print (Ultim)


CantFila = Cells(Rows.Count, 2).End(xlUp).Row
CantCol = Cells(2, Columns.Count).End(xlToLeft).Column


For f = 1 To CantFila Step 1
    For c = 1 To CantCol Step 1

    If (Left(Cells(f, c).Value, 3) = Ultim) Then
        Debug.Print (Left(Cells(f, c).Value, 3))
        a = Cells(f, c).Value
        Cells(m, n).Value = a
        n = n + 1
        Ultim = Left(Cells(f, c).Value, 3)
    
    ElseIf ((Left(Cells(f, c).Value, 3) <> Ultim) And Left(Cells(f, c).Value, 3) = "") Then
        f = f + 1
        c = 1
        
        If (Left(Cells(f, c).Value, 3) = Ultim) Then
        a = Cells(f, c).Value
        Cells(m, n).Value = a
        n = n + 1
        Ultim = Left(Cells(f, c).Value, 3)
        End If
    
    Else
        
        m = m + 1
        n = 1
        a = Cells(f, c).Value
        Cells(m, n).Value = a
        Ultim = Left(Cells(f, c).Value, 3)
    
    End If

    Next c
Next f

End Sub