Option Explicit

Sub tt()
    Dim a(), i&, k
    Dim outDic As Object
    Dim x&, y&, z&, b()

    Set outDic = CreateObject("Scripting.Dictionary"): outDic.comparemode = 1

    a = [a1].CurrentRegion.Columns(3).Resize(, 2).Value
    b = [q6].CurrentRegion.Value

    For x = 2 To UBound(b)
        For y = 2 To UBound(b, 2)
            If b(1, x) <> b(y, 1) Then

                If Not outDic.exists(b(1, x) & "|" & b(y, 1)) Then
                    z = 0
                    With CreateObject("Scripting.Dictionary"): .comparemode = 1
                        For i = 2 To UBound(a)
                            Select Case a(i, 1)
                            Case b(1, x)
                                .Item(a(i, 2)) = .Item(a(i, 2)) & "Y"
                            Case b(y, 1)
                                .Item(a(i, 2)) = .Item(a(i, 2)) & "Y"
                            End Select
                        Next

                        For Each k In .keys
                            If .Item(k) = "YY" Then z = z + 1
                        Next
                    End With
                    outDic.Item(b(1, x) & "|" & b(y, 1)) = z
                    outDic.Item(b(y, 1) & "|" & b(1, x)) = z
                End If

                b(y, x) = outDic.Item(b(y, 1) & "|" & b(1, x))
            Else
                b(y, x) = "|||||"
            End If
        Next
    Next

    [q6].CurrentRegion.Value = b

End Sub

Sub t()
  Dim a(), i&, j&, dkeys(), b%(), tt, s$, ik$, ii&, jj&
  Dim dc As Object, dm As Object, d As Object, dr As Object
  
  tt = Time
  Set dc = CreateObject("scripting.dictionary")
  Set dm = CreateObject("scripting.dictionary")
  With Sheets(1): a = Range(.[c2], .Cells(.Rows.Count, "d").End(xlUp)).Value: End With
  
  For i = 1 To UBound(a)
    If dm.exists(a(i, 1)) Then Set d = dm(a(i, 1)) Else Set d = CreateObject("scripting.dictionary")
    d(a(i, 2)) = 0&
    Set dm(a(i, 1)) = d
    If Not dc.exists(a(i, 1)) Then dc(a(i, 1)) = dc.Count + 1
  Next
  
  dkeys = dm.keys: Set dr = CreateObject("scripting.dictionary")
  For i = 0 To UBound(dkeys) - 1
    ik = dc(dkeys(i)) & " "
    For j = i + 1 To UBound(dkeys)
      For Each x In dm(dkeys(i))
        If dm(dkeys(j)).exists(x) Then s = ik & dc(dkeys(j)): dr(s) = dr(s) + 1
      Next
  Next j, i
  
  Set w = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
  w.[a2].Resize(dc.Count).Value = Application.Transpose(dc.keys)
  w.[b1].Resize(, dc.Count).Value = dc.keys
  ReDim b(1 To dc.Count, 1 To dc.Count)
  For Each x In dr.keys
    aa = Split(x): ii = CInt(aa(0)): jj = CInt(aa(1))
    b(ii, jj) = dr(x): b(jj, ii) = dr(x)
  Next
  w.[b2].Resize(UBound(b), UBound(b)).Value = b
  MsgBox Format(Time - tt, "hh:mm:ss")
End Sub