Solution to count how many elements many data sets have in common

[bazuca]

Hi everyone,

I am finding myself in this problem I can't solve.

I have 150 sets, each of which has multiple element inside i.e.

Set A
-1
-2
-3
-4

Set B
-1
-3
-10
-20

etc.

Now, I would like to create a matrix with the sets in rows and colum and for each intersecation I woudl like to count how many things the 2 sets have in common.

In this way, each set will have, in the intersecation with itself, all its element in common.

Is there a solution (vba included) to do this?

Thanks in advance

 

[Eric W]

Welcome to the forum.

Given this sheet:

Excel 2012

	A	B	C	D
1	Set A	Set B	Set C	Set D
2	-1	-1	-1	-4
3	-2	-3	-3	-41
4	-3	-10	-10	-42
5	-4	-20	-30	-50
6			-41
7			-42

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

This macro:

Sub Intersections()
Dim Dict() As Object, sht1 As Worksheet, sht2 As Worksheet, OutTab() As Variant
Dim lc As Long, r As Long, c As Long, ctr As Long, x As Variant

    Set sht1 = Sheets("Sheet1")
    Set sht2 = Sheets("Sheet2")
    
    sht2.Cells.ClearContents
    lc = sht1.Cells(1, Columns.Count).End(xlToLeft).Column
    ReDim Dict(1 To lc)
    ReDim OutTab(1 To lc + 1, 1 To lc + 1)
    
    For c = 1 To lc
        Set Dict(c) = CreateObject("Scripting.Dictionary")
        d1 = sht1.Cells(1, c).Resize(sht1.Cells(Rows.Count, c).End(xlUp).Row).Value
        For r = 2 To UBound(d1)
            Dict(c)(d1(r, 1)) = 1
        Next r
        OutTab(c + 1, 1) = d1(1, 1)
        OutTab(1, c + 1) = d1(1, 1)
    Next c
    
    For r = 1 To lc
        For c = r To lc
            If r = c Then
                ctr = Dict(c).Count
            Else
                ctr = 0
                For Each x In Dict(r)
                    If Dict(c).exists(x) Then ctr = ctr + 1
                Next x
            End If
            OutTab(r + 1, c + 1) = ctr
            OutTab(c + 1, r + 1) = ctr
        Next c
    Next r
    sht2.Range("A1").Resize(lc + 1, lc + 1) = OutTab
    
End Sub

will create this sheet:

Excel 2012

	A	B	C	D	E
1		Set A	Set B	Set C	Set D
2	Set A	4	2	2	1
3	Set B	2	4	3	0
4	Set C	2	3	6	2
5	Set D	1	0	2	4

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet2​

Let me know if this is what you're looking for.

 

[bazuca]

Welcome to the forum.

Given this sheet:

Excel 2012

	A	B	C	D
1	Set A	Set B	Set C	Set D
2	-1	-1	-1	-4
3	-2	-3	-3	-41
4	-3	-10	-10	-42
5	-4	-20	-30	-50
6			-41
7			-42

<tbody>
</tbody>

Sheet1​

This macro:

Sub Intersections()
Dim Dict() As Object, sht1 As Worksheet, sht2 As Worksheet, OutTab() As Variant
Dim lc As Long, r As Long, c As Long, ctr As Long, x As Variant

    Set sht1 = Sheets("Sheet1")
    Set sht2 = Sheets("Sheet2")
    
    sht2.Cells.ClearContents
    lc = sht1.Cells(1, Columns.Count).End(xlToLeft).Column
    ReDim Dict(1 To lc)
    ReDim OutTab(1 To lc + 1, 1 To lc + 1)
    
    For c = 1 To lc
        Set Dict(c) = CreateObject("Scripting.Dictionary")
        d1 = sht1.Cells(1, c).Resize(sht1.Cells(Rows.Count, c).End(xlUp).Row).Value
        For r = 2 To UBound(d1)
            Dict(c)(d1(r, 1)) = 1
        Next r
        OutTab(c + 1, 1) = d1(1, 1)
        OutTab(1, c + 1) = d1(1, 1)
    Next c
    
    For r = 1 To lc
        For c = r To lc
            If r = c Then
                ctr = Dict(c).Count
            Else
                ctr = 0
                For Each x In Dict(r)
                    If Dict(c).exists(x) Then ctr = ctr + 1
                Next x
            End If
            OutTab(r + 1, c + 1) = ctr
            OutTab(c + 1, r + 1) = ctr
        Next c
    Next r
    sht2.Range("A1").Resize(lc + 1, lc + 1) = OutTab
    
End Sub

will create this sheet:

Excel 2012

	A	B	C	D	E
1		Set A	Set B	Set C	Set D
2	Set A	4	2	2	1
3	Set B	2	4	3	0
4	Set C	2	3	6	2
5	Set D	1	0	2	4

<tbody>
</tbody>

Sheet2​

Let me know if this is what you're looking for.

It does work like magic!!! Many thanks )

 

[Eric W]

You're welcome!