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

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
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
161
MichelleH77
M
P
  • Question Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
523
Micron
M
C
  • Question Question
Need help! extract value in special case, find many method, cannot solve it!
Replies
6
Views
177
CLKinfo
C
E
  • Question Question
Report that multiplies tables ('tree tables')
Replies
1
Views
245
Cubist
Cubist
P
  • Question Question
TypeScript (or other solutions) for modifying given list of cells (and similar problems)
Replies
0
Views
284
Pingaware
P

Forum statistics

Threads
1,224,823
Messages
6,181,180
Members
453,021
Latest member
Justyna P

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