Option Explicit

Sub ВертГориз()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets(1)
    
    Dim dic1 As Object
    Set dic1 = CreateObject("Scripting.Dictionary")
    Dim dic2 As Object
    Set dic2 = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
    
    GetDic sh1, dic1, dic2, arr
        
        
    Dim u As Long
    Dim y As Long
    Dim x As Integer
    Dim brr As Variant
    ReDim brr(1 To dic1.Count + 1, 1 To dic2.Count + 1)
        
    For u = 0 To dic1.Count - 1
        brr(dic1.Items()(u), 1) = dic1.Keys()(u)
    Next
    For u = 0 To dic2.Count - 1
        brr(1, dic2.Items()(u)) = dic2.Keys()(u)
    Next
        
    For u = 2 To UBound(arr, 1)
        y = dic1.Item(arr(u, 3))
        x = dic2.Item(arr(u, 1))
        brr(y, x) = brr(y, x) + 1
    Next
    
    With Workbooks.Add(1)
        .Sheets(1).Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        .Saved = True
    End With
End Sub

Private Function GetDic(sh As Worksheet, dic1 As Object, dic2 As Object, arr As Variant) As Boolean
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 3))
    End With
    
    Set sh = Workbooks.Add(1).Sheets(1)
    Dim brr As Variant
    Dim u As Integer
    
    sh.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C2:C" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'        .SortFields.Add Key:=Range("B2:B" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:C" & y)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    brr = sh.Cells(1, 3).Resize(y, 1)
    u = 1
    For y = 2 To UBound(brr, 1)
        If Not dic1.Exists(brr(y, 1)) Then
            u = u + 1
            dic1.Item(brr(y, 1)) = u
        End If
    Next
    '----------------------------------------------------------------------------------------------------------
    
    
    sh.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'        .SortFields.Add Key:=Range("B2:B" & y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:C" & y)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    brr = sh.Cells(1, 1).Resize(y, 1)
    u = 1
    For y = 2 To UBound(brr, 1)
        If Not dic2.Exists(brr(y, 1)) Then
            u = u + 1
            dic2.Item(brr(y, 1)) = u
        End If
    Next
    
    sh.Parent.Close False
End Function