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

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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

P
  • Question Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
462
Micron
M
E
  • Question Question
Report that multiplies tables ('tree tables')
Replies
1
Views
236
Cubist
Cubist
W
  • Question Question
Excel VBA - Check For Duplicates and Return the Count on a Large Data Set
Replies
4
Views
262
Kaper
Kaper
T
  • Solved
Integer programming with binary variables in Solver - issue with constraint?
Replies
3
Views
273
StephenCrump
S
K
  • Solved
Change ComboBox list values depending on the selected OptionButton
Replies
2
Views
879
Kakaska
K

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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