Show intersection values across excel file

Question

I have table with around 8000 rows .

This is just example of that :

I need to show the intersection values across the column Co. For example , I need to show a result like this :

To describe the result . It looks to the table and show how many No column have shared the same Co. For example : the value 12 in column Co. with 9 there is one number which have 12 and 9 in same time . With 12 itself it shows 3 because there are : 456 ,457 , and 458 have the value 12 . And so on with other values . I tried with pivot table but it did not help me because it works with one column at the same time ( it does not allow me to produce table with result like what I want ) . I was trying to use PowerBi but it also not help me . Any one can help ? Thank you

Answer 1

Put the data on Sheet1, the result goes to Sheet2.

Option Explicit

Sub macro()

    Dim i As Long, j As Long, n As Long
    Dim sCo As String, sNo As String
    Dim dictNo As Object, dictCo As Object, key
    Dim ar() As Long, arNo As Variant
    Set dictNo = CreateObject("Scripting.Dictionary")
    Set dictCo = CreateObject("Scripting.Dictionary")

    n = 0
    For i = 2 To 10
       sCo = CStr(Sheet1.Cells(i, 2))
       sNo = CStr(Sheet1.Cells(i, 3))
       ' axis
       If Not dictCo.exists(sCo) Then
           dictCo(sCo) = n
           n = n + 1
       End If

       ' intersects
       If dictNo.exists(sNo) Then
           dictNo(sNo) = dictNo(sNo) & "," & sCo
       Else
           dictNo(sNo) = sCo
       End If
    Next
   
    ' size the count array and fill in the axis
    ' top row and end column
    n = dictCo.Count
    ReDim ar(n + 1, n + 1)
    i = 0
    For Each key In dictCo
        ar(0, i) = key
        ar(i + 1, n) = key
        i = i + 1
    Next

    ' calc counts
    Dim x As Long, y As Long
    For Each key In dictNo
        arNo = Split(dictNo(key), ",")
        For i = 0 To UBound(arNo)
            x = CLng(dictCo(arNo(i)))
            For j = 0 To UBound(arNo)
                y = CLng(dictCo(arNo(j)))
                ar(x + 1, y) = ar(x + 1, y) + 1
            Next
        Next
    Next

    ' result
    Dim rng As Range
    Set rng = Sheet2.Range("A1").Resize(n + 1, n + 1)
    rng.Value2 = ar
    rng.Font.Bold = True
    With rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
   
    ' sort table rows
    Set rng = Sheet2.Columns(n + 1)
    With Sheet2.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng, _
           SortOn:=xlSortOnValues, Order:=xlAscending, _
           DataOption:=xlSortNormal
        .SetRange Sheet2.Range("A2").Resize(n, n + 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' sort table columns
    Set rng = Sheet2.Cells(1, 1).Resize(1, n + 1)
    With Sheet2.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng, _
           SortOn:=xlSortOnValues, Order:=xlDescending, _
           DataOption:=xlSortNormal
        .SetRange Sheet2.Range("A1").Resize(n + 1, n + 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    ' color
    rng.Interior.Color = RGB(220, 220, 255)
    Sheet2.Cells(1, n + 1).Resize(n + 1, 1).Interior.Color = RGB(220, 220, 255)
    Sheet2.Range("A1").Offset(0, n) = "Co"
    
    MsgBox "Done"

End Sub