Sub CalcDist()
Dim iCl1%, iCl2%, iRw1%, iRw2%, sNmCl1$, sNmCl2$
Dim lLr%, i%

Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare

With Worksheets(2)
lLr = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lLr
oDict.Item(.Cells(i, 1).Value) = i
Next i
End With

For iCl1 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 3 Step 3 ' направо
iCl2 = iCl1 + 3
sNmCl1 = Cells(1, iCl1).Value
sNmCl2 = Cells(1, iCl2).Value
iRw1 = 0: iRw2 = 0

For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
If sNmCl2 = Cells(i, iCl1).Value Then
iRw1 = i
End If
Next i
For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
If sNmCl1 = Cells(i, iCl2).Value Then
iRw2 = i
End If
Next i

If iRw1 <> 0 And iRw2 <> 0 Then
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
Else
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
End If

Next iCl1

For iCl1 = Cells(1, Columns.Count).End(xlToLeft).Column - 1 To 2 Step -3 ' налево
iCl2 = iCl1 - 3
sNmCl1 = Cells(1, iCl1).Value
sNmCl2 = Cells(1, iCl2).Value
iRw1 = 0: iRw2 = 0
For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
If sNmCl2 = Cells(i, iCl1).Value Then
iRw1 = i
End If
Next i
For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
If sNmCl1 = Cells(i, iCl2).Value Then
iRw2 = i
End If
Next i

If iRw1 <> 0 And iRw2 <> 0 Then
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
Else
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
End If
Next iCl1
End Sub