Подсчет совпадающих значений в ячейках

Sub AnalizRazmerov2()
    Dim a(), i&, kodDict As Object, testDict As Object, nomDict As Object, countDict As Object
    Dim t$, el
 
    Set testDict = CreateObject("Scripting.Dictionary"): testDict.comparemode = 1
    Set kodDict = CreateObject("Scripting.Dictionary"): kodDict.comparemode = 1
    Set nomDict = CreateObject("Scripting.Dictionary"): nomDict.comparemode = 1
    Set countDict = CreateObject("Scripting.Dictionary"): countDict.comparemode = 1
 
    Sheets("Готовая").UsedRange.ClearContents
 
    a = Sheets("ШК").[A1].CurrentRegion.Value
    For i = 2 To UBound(a): testDict.Item(a(i, 1)) = testDict.Item(a(i, 1)) + 1: Next
 
    a = Sheets("Размеры").[A1].CurrentRegion.Value
    For i = 2 To UBound(a)
        If testDict.exists(a(i, 11)) Then
            t = a(i, 1) & "|" & a(i, 4)
            If Not kodDict.exists(t) Then kodDict.Item(t) = a(i, 1)
            If Not nomDict.exists(t) Then nomDict.Item(t) = a(i, 4)
            countDict.Item(t) = testDict.Item(a(i, 11)) 'countDict.Item(t) + 1
        End If
    Next
 
    ReDim a(1 To kodDict.Count + 1, 1 To 3)
    i = 1
    a(i, 1) = "Артикул"
    a(i, 2) = "Размер"
    a(i, 3) = "Кол-во"
 
    For Each el In kodDict.keys
        i = i + 1
        a(i, 1) = kodDict.Item(el)
        a(i, 2) = nomDict.Item(el)
        a(i, 3) = countDict.Item(el)
    Next
 
    With Sheets("Готовая").Range("A1").Resize(i, 3)
        .Columns(1).NumberFormat = "@"
        .Value = a
    End With
End Sub

Sub tt()
    Dim a(), i&, kodDict As Object
    Dim t$, el
 
    Set kodDict = CreateObject("Scripting.Dictionary"): kodDict.comparemode = 1
 
    Sheets("Готовая").UsedRange.ClearContents
    a = Sheets("ШК").[A1].CurrentRegion.Value
 
    For i = 2 To UBound(a): kodDict.Item(a(i, 1)) = kodDict.Item(a(i, 1)) + 1: Next
    ReDim a(1 To kodDict.Count + 1, 1 To 3)
    i = 1
    a(i, 1) = "Артикул"
    a(i, 2) = "Размер"
    a(i, 3) = "Кол-во"
 
    For Each el In kodDict.keys
        i = i + 1
        a(i, 1) = Mid(el, 3, 8)
        a(i, 2) = Mid(el, 11, 2)
        a(i, 3) = kodDict.Item(el)
    Next
    With Sheets("Готовая").Range("A1").Resize(i, 3)
        .Columns(1).NumberFormat = "@"
        .Value = a
    End With
 
End Sub

Sub AnalizRazmerov3()
    Dim a(), i&, t&, el
 
    With CreateObject("Scripting.Dictionary"): .comparemode = 1
 
        Sheets("Готовая").UsedRange.ClearContents
 
        a = Sheets("ШК").[A1].CurrentRegion.Value
        For i = 2 To UBound(a): .Item(a(i, 1)) = .Item(a(i, 1)) + 1: Next
 
        ReDim b(1 To .Count + 1, 1 To 3)
        i = 1: b(i, 1) = "Артикул": b(i, 2) = "Размер": b(i, 3) = "Кол-во"
 
        For Each el In .keys
            i = i + 1: b(i, 3) = .Item(el): .Item(el) = i
        Next
 
        a = Sheets("Размеры").[A1].CurrentRegion.Value
        For i = 2 To UBound(a)
            If .exists(a(i, 11)) Then
                t = .Item(a(i, 11)): b(t, 1) = a(i, 1): b(t, 2) = a(i, 4)
            End If
        Next
 
    End With
 
    With Sheets("Готовая").Range("A1").Resize(UBound(b), 3)
        .Columns(1).NumberFormat = "@": .Value = b
    End With
End Sub