Подсчитать количество строк и ввести данные в другие ячейки желательно средствами VBA

Sub Schot_Modeley()
    Dim i&, j&, k&, A, S$, DicA, DicB, DicC, vX
    Set DicA = CreateObject("Scripting.Dictionary")
    Set DicB = CreateObject("Scripting.Dictionary")
    Set DicC = CreateObject("Scripting.Dictionary")
    DicA.CompareMode = 1: DicB.CompareMode = 1: DicC.CompareMode = 1
    With ActiveSheet
        .Cells.UnMerge
        A = .[A1].CurrentRegion.Value
        k = .[A1].End(xlDown).Row + 1
        j = .UsedRange.Rows.Count - .UsedRange.Row + 1
        .Rows(k & ":" & j).Clear
        For i = 1 To UBound(A, 1)
            DicC(Trim$(A(i, 3))) = 0&
            S = Trim$(A(i, 1)) & "|" & Trim$(A(i, 2))
            DicB(S) = 0&
            S = S & "|" & Trim$(A(i, 3))
            DicA(S) = DicA(S) + 1
        Next i
        .Cells(k + 2, 3) = "модель"
        Range(.Cells(k + 2, 3), .Cells(k + 2, DicC.Count + 2)).Merge
        .Cells(k + 2, 3).HorizontalAlignment = xlCenter
        k = k + 3
        .Cells(k, 1) = "дата"
        .Cells(k, 2) = "Фирма"
        j = 2
        For Each vX In DicC.Keys
            j = j + 1
            .Cells(k, j) = vX
        Next vX
        i = k
        For Each vX In DicB.Keys
            i = i + 1
            .Cells(i, 1) = Split(vX, "|")(0)
            .Cells(i, 2) = Split(vX, "|")(1)
        Next vX
        For i = 1 To DicB.Count
            For j = 1 To DicC.Count
                S = .Cells(k + i, 1) & "|" & .Cells(k + i, 2) & "|" & .Cells(k, 2 + j)
                If DicA.Exists(S) Then
                    .Cells(k + i, 2 + j) = DicA(S)
                End If
            Next j
        Next i
    End With
    Set DicA = Nothing: Set DicB = Nothing: Set DicC = Nothing
End Sub

'...
        a = DicC.Keys
        SortArray a
        For Each vX In a
            j = j + 1
            .Cells(k, j) = vX
        Next vX
'....
 
 
Private Sub SortArray(ByRef a As Variant)
    Dim i As Long, j As Long
    Dim t As Variant
  
    'standard bubble sort loops
    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If a(i) > a(j) Then 'change to < for descending order
                t = a(i)
                a(i) = a(j)
                a(j) = t
            End If
        Next j
    Next i
End Sub