Count unique values upon three criteria

premvinoth

New Member
Joined
Aug 4, 2015
Messages
16
Hi,

I have about 1,500 rows of data as mentioned below. Everyday I would need to prepare a report for the previous 3 days. (That file contains only previous 3 days data). For each date, for each of the dealer, i need to count the product and generate a report as shown at the bottom...
DateDealerProduct
08/03/2015Dealer AMobile phone
08/03/2015Dealer AWatch
08/03/2015Dealer A Mobile Phone
08/03/2015Dealer ALaptop
08/03/2015Dealer ALaptop
08/03/2015Dealer AMobile Phone
08/02/2015Dealer ALaptop
08/02/2015Dealer AWatch
08/02/2015Dealer AWatch
08/01/2015Dealer AMobile phone

<tbody>
</tbody>

DealerDealer total countDay1 countDay1 product wise countDay2 countDay2 product wise countDay3 countDay3 product wise count
Dealer A1063-Mobile phone, 2-Laptop, 1-Watch32-Watch, 1-Laptop11-Mobile phone

<tbody>
</tbody>

The product wise count needs to be in a descending order based on the count. Show here is sample data for one dealer (Dealer A), there are 10 dealers in the dataset, and this similar report needs to be generated in a single sheet.

I would highly appreciate your support in automating it in VBA. Thank you in advance.

Regards,
Vinoth
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Try this for Data on sheet 1 and Results sheet 2.
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Aug18
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, g [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] y [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
  ReDim ray(1 To Rng.Count, 1 To Rng.Count)


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
      [COLOR="Navy"]End[/COLOR] If
      
       [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                        Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
       [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                  Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 1).Value), 1
            [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) + 1
            [COLOR="Navy"]End[/COLOR] If
                  
[COLOR="Navy"]Next[/COLOR] Dn
   
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
   ac = 3: c = c + 1: y = 0
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k).Keys
         y = y + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] g [COLOR="Navy"]In[/COLOR] Dic(k)(p).Keys
                ray(1, 1) = "Dealer": ray(1, 2) = "Dealer Total"
                ray(1, ac) = "Day" & y & " " & "Count"
                ray(1, ac + 1) = "Day" & y & " " & "Prouduct Wise Count"
                ray(c, 1) = k
                ray(c, 2) = Application.CountIf(Rng, k)
                ray(c, ac) = ray(c, ac) + Dic(k)(p)(g)
                ray(c, ac + 1) = ray(c, ac + 1) & "," & Dic(k)(p)(g) & "-" & g
                [COLOR="Navy"]If[/COLOR] Left(ray(c, ac + 1), 1) = "," [COLOR="Navy"]Then[/COLOR] ray(c, ac + 1) = Mid((Dic(k)(p)(g) & "-" & g), 1)
            [COLOR="Navy"]Next[/COLOR] g
      ac = ac + 2
     oMax = Application.Max(oMax, ac)
     [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax - 1)
    .Value = ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Many thanks to you.. it is working amazing.

Is is possible to make the contents in the "Product wise count" to be listed in a order like 'Products with highest count on the first and least count on the last' (Descending order).

Once again thank you for your precious time.

Regards,
Vinoth
 
Upvote 0
Perhaps this ?? :-
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Aug34
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant, g [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] y [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
  ReDim Ray(1 To Rng.Count, 1 To Rng.Count)


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
      [COLOR="Navy"]End[/COLOR] If
      
       [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, -1).Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                        Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
       [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                  Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 1).Value), 1
            [COLOR="Navy"]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) + 1
            [COLOR="Navy"]End[/COLOR] If
                  
[COLOR="Navy"]Next[/COLOR] Dn
   
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
   ac = 3: c = c + 1: y = 0
     [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k).Keys
         y = y + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] g [COLOR="Navy"]In[/COLOR] Dic(k)(p).Keys
                Ray(1, 1) = "Dealer": Ray(1, 2) = "Dealer Total"
                Ray(1, ac) = "Day" & y & " " & "Count"
                Ray(1, ac + 1) = "Day" & y & " " & "Prouduct Wise Count"
                Ray(c, 1) = k
                Ray(c, 2) = Application.CountIf(Rng, k)
                Ray(c, ac) = Ray(c, ac) + Dic(k)(p)(g)
                Ray(c, ac + 1) = Ray(c, ac + 1) & "," & Dic(k)(p)(g) & "-" & g
                [COLOR="Navy"]If[/COLOR] Left(Ray(c, ac + 1), 1) = "," [COLOR="Navy"]Then[/COLOR] Ray(c, ac + 1) = Mid((Dic(k)(p)(g) & "-" & g), 1)
            [COLOR="Navy"]Next[/COLOR] g
      
      Sp = Split(Ray(c, ac + 1), ",")
      [COLOR="Navy"]If[/COLOR] UBound(Sp) > 0 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] i = 0 To UBound(Sp) - 1
            [COLOR="Navy"]For[/COLOR] j = i To UBound(Sp)
                [COLOR="Navy"]If[/COLOR] Split(Sp(j), "-")(0) > Split(Sp(i), "-")(0) [COLOR="Navy"]Then[/COLOR]
                    temp = Sp(i)
                    Sp(i) = Sp(j)
                    Sp(j) = temp
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] j
        [COLOR="Navy"]Next[/COLOR] i
     [COLOR="Navy"]End[/COLOR] If
     Ray(c, ac + 1) = Join(Sp, ",")
      ac = ac + 2
     oMax = Application.Max(oMax, ac)
     [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax - 1)
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

I need your help on the above coding.. Please fix this issue....

I am preparing this report everyday for the three previous working days. So on Monday, I would generate this report for Friday(Day 1), Thursday (Day2) and Wednesday (Day 3). This code considers Thursday as Day1 and Wednesday as Day2, whenever there is no data for a particular Dealer on Friday.

Also if have have data for a particula dealer only for Day1(Friday) and Day3(Wednesday), it considers Wednesday as Day2.

I am sorting the date column in descending order so as to make the recent day as Day1 and the next days as Day2 and Day3.

Regards,
Vinoth
 
Upvote 0
If I look down column "A" and use the data shown in any of the cells, that have any of the first 3 dates, Will that give you what you want ??????
 
Upvote 0
Thank you for you response...

In the below example, 08/07/2015 is Day1, 08/06/2015 is Day2, 08/05/2015 is Day3.

DateDealerProduct
8/7/2015Dealer AMobile Phone
8/7/2015Dealer ALaptop
8/7/2015Dealer ALaptop
8/7/2015Dealer ALaptop
8/6/2015Dealer BWatch
8/6/2015Dealer BLaptop
8/6/2015Dealer BWatch
8/5/2015Dealer AMobile phone
8/5/2015Dealer AMobile Phone
8/5/2015Dealer AWatch

<colgroup><col><col><col></colgroup><tbody>
</tbody>

I get this result

DealerDealer Total Day1 CountDay1 Product Wise CountDay2 CountDay2 Reason Wise Count
Dealer A743-Laptop, 1-Mobile Phone32-Mobile phone, 1-Watch
Dealer B332-Watch, 1-Laptop

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

The expected result is

DealerDealer TotalDay1 CountDay1 Reason Wise CountDay2 CountDay2 Reason Wise CountDay3 Count Day3 Reason Wise Count
Dealer A743-Laptop, 1-Mobile Phone 32-Mobile phone, 1-Watch
Dealer B3 32-Watch, 1-Laptop


<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
Try this:-
The code assumes there are a maximum of 3 different dates in the data and the data is sorted by date (descending)
Code:
[COLOR=Navy]Sub[/COLOR] MG11Aug03
'[COLOR=Green][B]Date positions[/B][/COLOR]
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Dic [COLOR=Navy]As[/COLOR] Object, Q [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] K [COLOR=Navy]As[/COLOR] Variant, p [COLOR=Navy]As[/COLOR] Variant, g [COLOR=Navy]As[/COLOR] Variant, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] oMax [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Sp [COLOR=Navy]As[/COLOR] Variant, i [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] j [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] temp [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] Dic2 [COLOR=Navy]As[/COLOR] Object
    [COLOR=Navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
[COLOR=Navy]With[/COLOR] Sheets("Sheet4")
    [COLOR=Navy]Set[/COLOR] Rng = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]End[/COLOR] With
  ReDim Ray(1 To Rng.Count, 1 To Rng.Count)


[COLOR=Navy]Set[/COLOR] Dic2 = CreateObject("scripting.dictionary")
Dic2.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng.Offset(, -1): Dic2(Dn.Value) = Empty: [COLOR=Navy]Next[/COLOR]
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
      [COLOR=Navy]End[/COLOR] If
      
       [COLOR=Navy]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, -1).Value) [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]Set[/COLOR] Dic(Dn.Value)(Dn.Offset(, -1).Value) = CreateObject("Scripting.Dictionary")
                        Dic(Dn.Value)(Dn.Offset(, -1).Value).CompareMode = 1
       [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]If[/COLOR] Not Dic(Dn.Value)(Dn.Offset(, -1).Value).Exists(Dn.Offset(, 1).Value) [COLOR=Navy]Then[/COLOR]
                  Dic(Dn.Value)(Dn.Offset(, -1).Value).Add (Dn.Offset(, 1).Value), 1
            [COLOR=Navy]Else[/COLOR]
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) = _
                    Dic(Dn.Value)(Dn.Offset(, -1).Value).Item(Dn.Offset(, 1).Value) + 1
            [COLOR=Navy]End[/COLOR] If
                  
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Dim[/COLOR] Col [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] H [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
c = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.Keys
   ac = 3: c = c + 1: Col = 0
     [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] p [COLOR=Navy]In[/COLOR] Dic(K).Keys
        [COLOR=Navy]Select[/COLOR] [COLOR=Navy]Case[/COLOR] True
         [COLOR=Navy]Case[/COLOR] p = Dic2.Keys()(0): Col = 3: H = 1
         [COLOR=Navy]Case[/COLOR] p = Dic2.Keys()(1): Col = 5: H = 2
         [COLOR=Navy]Case[/COLOR] p = Dic2.Keys()(2): Col = 7: H = 3
         [COLOR=Navy]End[/COLOR] Select
            [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] g [COLOR=Navy]In[/COLOR] Dic(K)(p).Keys
                
                Ray(1, 1) = "Dealer": Ray(1, 2) = "Dealer Total"
                Ray(1, Col) = "Day" & H & " " & "Count"
                Ray(1, Col + 1) = "Day" & H & " " & "Prouduct Wise Count"
                Ray(c, 1) = K
                Ray(c, 2) = Application.CountIf(Rng, K)
                Ray(c, Col) = Ray(c, Col) + Dic(K)(p)(g)
                Ray(c, Col + 1) = Ray(c, Col + 1) & "," & Dic(K)(p)(g) & "-" & g
                [COLOR=Navy]If[/COLOR] Left(Ray(c, Col + 1), 1) = "," [COLOR=Navy]Then[/COLOR] Ray(c, Col + 1) = Mid((Dic(K)(p)(g) & "-" & g), 1)
            [COLOR=Navy]Next[/COLOR] g
      
      Sp = Split(Ray(c, Col + 1), ",")
      [COLOR=Navy]If[/COLOR] UBound(Sp) > 0 [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]For[/COLOR] i = 0 To UBound(Sp) - 1
            [COLOR=Navy]For[/COLOR] j = i To UBound(Sp)
                [COLOR=Navy]If[/COLOR] Split(Sp(j), "-")(0) > Split(Sp(i), "-")(0) [COLOR=Navy]Then[/COLOR]
                    temp = Sp(i)
                    Sp(i) = Sp(j)
                    Sp(j) = temp
                [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]Next[/COLOR] j
        [COLOR=Navy]Next[/COLOR] i
     [COLOR=Navy]End[/COLOR] If
     Ray(c, Col + 1) = Join(Sp, ",")
     oMax = Application.Max(oMax, Col)
     [COLOR=Navy]Next[/COLOR] p
[COLOR=Navy]Next[/COLOR] K
[COLOR=Navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax + 2)
    .Parent.Range("A1").CurrentRegion.Clear
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0

Forum statistics

Threads
1,216,099
Messages
6,128,819
Members
449,469
Latest member
Kingwi11y

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