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

B

bazuca

New Member
Joined
Jun 2, 2018
Messages
2
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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Welcome to the forum.

Given this sheet:

Excel 2012
ABCD
Set ASet BSet CSet D

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-4[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"]-2[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-41[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-10[/TD]
[TD="align: right"]-10[/TD]
[TD="align: right"]-42[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"]-4[/TD]
[TD="align: right"]-20[/TD]
[TD="align: right"]-30[/TD]
[TD="align: right"]-50[/TD]

[TD="align: center"]6[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]-41[/TD]
[TD="align: right"][/TD]

[TD="align: center"]7[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]-42[/TD]
[TD="align: right"][/TD]

</tbody>
Sheet1​



This macro:

Code: 
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
ABCDE
Set ASet BSet CSet D
Set A
Set B
Set C
Set D

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]4[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]1[/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]0[/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]2[/TD]

[TD="align: center"]5[/TD]

[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]

</tbody>
Sheet2​



Let me know if this is what you're looking for.
 
Upvote 0
Eric W said:
Welcome to the forum.

Given this sheet:

Excel 2012
ABCD
Set ASet BSet CSet D

<tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-1[/TD]
[TD="align: right"]-4[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"]-2[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-41[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"]-3[/TD]
[TD="align: right"]-10[/TD]
[TD="align: right"]-10[/TD]
[TD="align: right"]-42[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"]-4[/TD]
[TD="align: right"]-20[/TD]
[TD="align: right"]-30[/TD]
[TD="align: right"]-50[/TD]

[TD="align: center"]6[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]-41[/TD]
[TD="align: right"][/TD]

[TD="align: center"]7[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]-42[/TD]
[TD="align: right"][/TD]

</tbody>
Sheet1​



This macro:

Code: 
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
ABCDE
Set ASet BSet CSet D
Set A
Set B
Set C
Set D

<tbody>
[TD="align: center"]1[/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]4[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]1[/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]0[/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]2[/TD]

[TD="align: center"]5[/TD]

[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]

</tbody>
Sheet2​



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

It does work like magic!!! Many thanks :))
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Timestamps - finding & measuring overlaps
Replies
5
Views
140
MichelleH77
M
P
  • Question Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
477
Micron
M
C
  • Question Question
Need help! extract value in special case, find many method, cannot solve it!
Replies
6
Views
143
CLKinfo
C
E
  • Question Question
Report that multiplies tables ('tree tables')
Replies
1
Views
238
Cubist
Cubist
W
  • Question Question
Excel VBA - Check For Duplicates and Return the Count on a Large Data Set
Replies
4
Views
305
Kaper
Kaper

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top