Dim dic1 As Object
Dim dicA As Object
Sub GetPair()
    Set dic1 = GetOneNodLength
    Dim dic2 As Object
      
    Dim b As String
    Dim c As String
    Dim v1 As Variant
    Dim v2 As Variant
    Dim v3 As Variant
    Dim bRun As Boolean
    Dim dic1Count As Long
    Do
        bRun = False
        For Each v1 In dic1.keys
            Set dic2 = dic1(v1)
            dic1Count = dic2.Count
            For Each v2 In dic2.keys
                b = Split(v2, "-")(1)
                For Each v3 In dic1(b).keys
                    c = Split(v3, "-")(1)
                    If Not dic1(v1).Exists(v1 & "-" & c) Then
                        dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3) 'Длина пути
                        dicA(v1)(v1 & "-" & c) = dicA(v1).Item(v2) & "-" & Mid(dicA(b).Item(v3), Len(b) + 2) 'А-Б
                    End If
                    If dic1(v1)(v1 & "-" & c) > dic1(v1).Item(v2) + dic1(b).Item(v3) Then
                        dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3) 'Длина пути
                        dicA(v1)(v1 & "-" & c) = dicA(v1).Item(v2) & "-" & Mid(dicA(b).Item(v3), Len(b) + 2) 'А-Б
                    End If
                Next
            Next
            If dic1Count <> dic2.Count Then
                bRun = True
            End If
        Next
        OutputDic
        If Not bRun Then Exit Do
    Loop
End Sub
 
Function GetOneNodLength() As Object
    Dim y As Long
    y = Cells(Rows.Count, 1).End(xlUp).Row
    Dim a As Variant
    a = Range(Cells(4, 1), Cells(y, 3))
      
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set dicA = CreateObject("Scripting.Dictionary")
    
    Dim v As Variant
    Dim i As Variant
      
    For y = 1 To UBound(a, 1)
        v = Split(a(y, 1), "-")
        For i = 0 To 1
            If Not dic.Exists(v(i)) Then
                Set dic(v(i)) = CreateObject("Scripting.Dictionary")
                Set dicA(v(i)) = CreateObject("Scripting.Dictionary")
            End If
            dic(v(i))(v(i) & "-" & v(1 - i)) = a(y, 3)
            dic(v(i))(v(i) & "-" & v(i)) = 0
            
            'А-Б
            dicA(v(i))(v(i) & "-" & v(1 - i)) = v(i) & "-" & v(1 - i)
            dicA(v(i))(v(i) & "-" & v(i)) = v(i) & "-" & v(i)
        Next
    Next
      
    Set GetOneNodLength = dic
End Function
 
Private Sub OutputDic()
    Dim y As Integer
    Dim x As Integer
    Dim y0 As Integer
    Dim x0 As Integer
    Dim s As String
    Dim p As String
      
    'Начало вывода
    Dim rOut As Range
    Set rOut = Range("F2")
    y0 = rOut.Row
    x0 = rOut.Column
    y = y0
    Do
        y = y + 1
        If Cells(y, x0) = "" Then Exit Do
    Loop
    Dim aHead As Variant
    aHead = Range(Cells(y0 + 1, x0), Cells(y, x0))
    Dim aOut As Variant
    ReDim aOut(1 To y, 1 To y)
     
    Dim aOuA As Variant
    ReDim aOuA(1 To y, 1 To y)
     
    For y = 1 To UBound(aHead, 1)
    For x = 1 To UBound(aHead, 1)
            s = aHead(x, 1)
            p = aHead(y, 1)
            If dic1.Exists(s) Then
                If dic1(s).Exists(s & "-" & p) Then
                    aOut(y, x) = dic1(s)(s & "-" & p)
                    aOuA(y, x) = dicA(s)(s & "-" & p)
                End If
            End If
    Next
    Next
     
    With rOut.Cells(2, 2).Resize(y, y)
        .ClearContents
        .Cells = aOut
    End With
    'А-Б. Вывод справа через какие точки проходит маршрут.
    With rOut.Cells(2, 2 + 50).Resize(y, y)
        .NumberFormat = "@"
        .ClearContents
        .Cells = aOuA
    End With
End Sub