VBA to find unique from multiple columns and count on multiple criteria. Anybody please

Ombir

Ombir

Active Member
Joined
Oct 1, 2015
Messages
433
Hi friends,


I have a worksheet shown below.


ABCDEF
DtSb1Sb2Sb3Sb4Sb5
AmENCHICPOSECOCPU
AmENCHICPOSMASMAT
BwENCHICPOSECOCPU
BwENCHOSPHECHEBIO
JnENCHICPOSECOCPU
JnENCHICPOSECOCPU
JnENCHICMATOSHOSE

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

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

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

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

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

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

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

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

</tbody>
Sheet3​




First I want to find Unique values based on Column 1 and Column(2-6) then count these values as shown below.

HIJ
DtSbCnt
AmENC
AmHIC
AmPOS
AmECO
AmCPU
AmMAS
AmMAT
BwENC
BwHIC
BwPOS
BwPHE
BwECO
BwCPU
BwCHE
BwBIO
JnENC
JnHIC
JnPOS
JnECO
JnCPU
JnMAT
JnOSH
JnOSE

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

</tbody>
Sheet3​


I am able to code this in Visual Fox Pro but can anybody help me with some VBA code to achieve this. Thanks
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG27Dec39
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Q [COLOR="Navy"]As[/COLOR] Variant
Ray = Range("a1").CurrentRegion.Resize(, 6)
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
nray(1, 1) = "Dt": nray(1, 2) = "Sb": nray(1, 3) = "Cnt"
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
n = 1


[COLOR="Navy"]For[/COLOR] Rw = 2 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(Rw, 1) & Ray(Rw, Ac)) [COLOR="Navy"]Then[/COLOR]
            n = n + 1
            nray(n, 1) = Ray(Rw, 1): nray(n, 2) = Ray(Rw, Ac): nray(n, 3) = 1
            Dic.Add Ray(Rw, 1) & Ray(Rw, Ac), Array(n, 1)
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(Ray(Rw, 1) & Ray(Rw, Ac))
                Q(1) = Q(1) + 1
                nray(Q(0), 3) = Q(1)
           Dic(Ray(Rw, 1) & Ray(Rw, Ac)) = Q
        
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Rw
Range("H1").Resize(n, 3) = nray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG27Dec39
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, Q [COLOR=Navy]As[/COLOR] Variant
Ray = Range("a1").CurrentRegion.Resize(, 6)
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
nray(1, 1) = "Dt": nray(1, 2) = "Sb": nray(1, 3) = "Cnt"
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
n = 1


[COLOR=Navy]For[/COLOR] Rw = 2 To UBound(Ray, 1)
    [COLOR=Navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(Ray(Rw, 1) & Ray(Rw, Ac)) [COLOR=Navy]Then[/COLOR]
            n = n + 1
            nray(n, 1) = Ray(Rw, 1): nray(n, 2) = Ray(Rw, Ac): nray(n, 3) = 1
            Dic.Add Ray(Rw, 1) & Ray(Rw, Ac), Array(n, 1)
        [COLOR=Navy]Else[/COLOR]
            Q = Dic(Ray(Rw, 1) & Ray(Rw, Ac))
                Q(1) = Q(1) + 1
                nray(Q(0), 3) = Q(1)
           Dic(Ray(Rw, 1) & Ray(Rw, Ac)) = Q
        
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] Rw
Range("H1").Resize(n, 3) = nray
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub [/COLOR]
Regards Mick
Click to expand...

Thanks a lot Mick. This code is working fine. My gut was also telling me to use dictionary to achieve this but couldn't able to figure out the solution. I am trying to understand how this code is working but I am stuck at two things.

1. What this Array(n,1) is doing ?
2. How this else part of If is working

Code: 
Q = Dic(Ray(Rw, 1) & Ray(Rw, Ac))
                Q(1) = Q(1) + 1
                nray(Q(0), 3) = Q(1)
           Dic(Ray(Rw, 1) & Ray(Rw, Ac)) = Q

I am learning VBA so unable to understand this. Could you please explain about these two things. Thanks.
 
Upvote 0
Hopefully this "Remarked" code will Help.
Code: 
[COLOR=Navy]Sub[/COLOR] MG28Dec42
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, Q [COLOR=Navy]As[/COLOR] Variant
Ray = Range("a1").CurrentRegion.Resize(, 6)
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
nray(1, 1) = "Dt": nray(1, 2) = "Sb": nray(1, 3) = "Cnt"
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
n = 1
'[COLOR=Green][B]If you familiar with "Scripting Dictionary" you will know it has[/B][/COLOR]
'[COLOR=Green][B]"Keys" and "Items" relating to those Keys:=[/B][/COLOR]
[COLOR=Navy]For[/COLOR] Rw = 2 To UBound(Ray, 1)
    [COLOR=Navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(Ray(Rw, 1) & Ray(Rw, Ac)) [COLOR=Navy]Then[/COLOR]
           
           '[COLOR=Green][B]"n" represents the Index of every new Unique value in dictionary "Keys"[/B][/COLOR]
           '[COLOR=Green][B]This "n" value is used to define each new row in the results Array "nRay"[/B][/COLOR]
            n = n + 1
            '[COLOR=Green][B]Fill first Row of new Unique Results[/B][/COLOR]
            nray(n, 1) = Ray(Rw, 1): nray(n, 2) = Ray(Rw, Ac): nray(n, 3) = 1
            
            '[COLOR=Green][B]Array(n,1) is the "ITEM" of each unique value (KEY) found indata and[/B][/COLOR]
            '[COLOR=Green][B]represents the value "n" giving the row location of each new value placed in array "nRay" and[/B][/COLOR]
            '[COLOR=Green][B]"1" which is the first count of each unique value found[/B][/COLOR]
            '[COLOR=Green][B] This count is increases in the Else statement, below when another count of the[/B][/COLOR]
            '[COLOR=Green][B]same Unique value is found !![/B][/COLOR]
            Dic.Add Ray(Rw, 1) & Ray(Rw, Ac), Array(n, 1)
        
        [COLOR=Navy]Else[/COLOR]
           '[COLOR=Green][B] The variable "Q" is used to represent the "ITEM" of each Unique (KEY)[/B][/COLOR]
           '[COLOR=Green][B] so "Q" is the "ITEM" of the "KEY" :- Ray(Rw, 1) & Ray(Rw, Ac)[/B][/COLOR]
            Q = Dic(Ray(Rw, 1) & Ray(Rw, Ac))
                
           '[COLOR=Green][B]There are 2 values in "Q", "Q0" the first value "n" and "Q1" the count of each subsequent[/B][/COLOR]
           '[COLOR=Green][B]Unique value found[/B][/COLOR]
           '[COLOR=Green][B]That count is increased by 1 each time another value, for that unique "KEY" is found[/B][/COLOR]
                Q(1) = Q(1) + 1
            
            '[COLOR=Green][B]Column 3 of the Results array nRay is increased by 1[/B][/COLOR]
                nray(Q(0), 3) = Q(1)
           
           '[COLOR=Green][B]The item resulting to "Q" is updated.[/B][/COLOR]
           Dic(Ray(Rw, 1) & Ray(Rw, Ac)) = Q
        
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] Rw
Range("H1").Resize(n, 3) = nray
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick,

Thanks for the explanation above.

Just one question

why the resize on the current region?
 
Upvote 0
It just limits the array to 6 columns.
If the number of columns had been greater that 6 then the code will have looked at those extra columns when I used ubound(ray,2).
 
Upvote 0
Thanks, that makes sense.

I see you use scripting library quite often is this user preference or an absolute better way to go.

Is there a good learning place for the scripting library?
 
Upvote 0
Thanks Mick,

I like the fact the site is not discriminatory as well.

It says VBA for smarties but let me in anyway
 
Upvote 0
MickG said:
Hopefully this "Remarked" code will Help.
Code: 
[COLOR=Navy]Sub[/COLOR] MG28Dec42
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, Q [COLOR=Navy]As[/COLOR] Variant
Ray = Range("a1").CurrentRegion.Resize(, 6)
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
nray(1, 1) = "Dt": nray(1, 2) = "Sb": nray(1, 3) = "Cnt"
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
n = 1
'[COLOR=Green][B]If you familiar with "Scripting Dictionary" you will know it has[/B][/COLOR]
'[COLOR=Green][B]"Keys" and "Items" relating to those Keys:=[/B][/COLOR]
[COLOR=Navy]For[/COLOR] Rw = 2 To UBound(Ray, 1)
    [COLOR=Navy]For[/COLOR] Ac = 2 To UBound(Ray, 2)
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(Ray(Rw, 1) & Ray(Rw, Ac)) [COLOR=Navy]Then[/COLOR]
           
           '[COLOR=Green][B]"n" represents the Index of every new Unique value in dictionary "Keys"[/B][/COLOR]
           '[COLOR=Green][B]This "n" value is used to define each new row in the results Array "nRay"[/B][/COLOR]
            n = n + 1
            '[COLOR=Green][B]Fill first Row of new Unique Results[/B][/COLOR]
            nray(n, 1) = Ray(Rw, 1): nray(n, 2) = Ray(Rw, Ac): nray(n, 3) = 1
            
            '[COLOR=Green][B]Array(n,1) is the "ITEM" of each unique value (KEY) found indata and[/B][/COLOR]
            '[COLOR=Green][B]represents the value "n" giving the row location of each new value placed in array "nRay" and[/B][/COLOR]
            '[COLOR=Green][B]"1" which is the first count of each unique value found[/B][/COLOR]
            '[COLOR=Green][B] This count is increases in the Else statement, below when another count of the[/B][/COLOR]
            '[COLOR=Green][B]same Unique value is found !![/B][/COLOR]
            Dic.Add Ray(Rw, 1) & Ray(Rw, Ac), Array(n, 1)
        
        [COLOR=Navy]Else[/COLOR]
           '[COLOR=Green][B] The variable "Q" is used to represent the "ITEM" of each Unique (KEY)[/B][/COLOR]
           '[COLOR=Green][B] so "Q" is the "ITEM" of the "KEY" :- Ray(Rw, 1) & Ray(Rw, Ac)[/B][/COLOR]
            Q = Dic(Ray(Rw, 1) & Ray(Rw, Ac))
                
           '[COLOR=Green][B]There are 2 values in "Q", "Q0" the first value "n" and "Q1" the count of each subsequent[/B][/COLOR]
           '[COLOR=Green][B]Unique value found[/B][/COLOR]
           '[COLOR=Green][B]That count is increased by 1 each time another value, for that unique "KEY" is found[/B][/COLOR]
                Q(1) = Q(1) + 1
            
            '[COLOR=Green][B]Column 3 of the Results array nRay is increased by 1[/B][/COLOR]
                nray(Q(0), 3) = Q(1)
           
           '[COLOR=Green][B]The item resulting to "Q" is updated.[/B][/COLOR]
           Dic(Ray(Rw, 1) & Ray(Rw, Ac)) = Q
        
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] Rw
Range("H1").Resize(n, 3) = nray
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...

Thanks for the explanation Mick. Now I am getting a clear picture of this code but still have few doubts.

1. How this code is identifying that Q will contain 2 values. You have declared it as variant but dimension is not available.
2. For first iteration of any key in else statement Q(1) is calculating count of 2 but initial value of Q(1) is not declared as 1. Is it taking initial value as 1 by default ?
3. Is there any link between Array(n,1) and Q ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
Formula to count with multiple criteria and exclude from a separate column, then sort by count in one cell with spill
Replies
0
Views
568
Greenbehindthecells
G
darrenmccoy
  • Question Question
Help to Index unique records in Multiple columns
2
Replies
11
Views
1K
Peter_SSs
Peter_SSs
D
  • Question Question
Search for multiple values w/ one criteria but show unique values only
Replies
5
Views
673
sandy666
sandy666
P
  • Question Question
Count unique value comparing multiple coloumn
Replies
2
Views
557
DanteAmor
DanteAmor
M
  • Question Question
Count Unique Values That Meet Criteria
Replies
2
Views
634
masouder
M

Forum statistics

Threads
1,223,728
Messages
6,174,150
Members
452,548
Latest member
Enice Anaelle

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