need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

K

kbishop94

Active Member
Joined
Dec 5, 2016
Messages
458
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
See picture.. pretty self-explanatory (I hope at least)
Columns D & E show the result I am trying to do.

So I need to: provide a count all the unique entries, and a count for all the duplicate values too that are listed in column A, display the results somewhere on the same sheet.... then, sort them by the most entries for each name.
THis will ultimately be a 'workbook open' event as I need to have it calculate the tallys for all the columns (there will be 9 or 10 columns that I want to run the query for) whenever the user opens the workbook.

I have several columns total that I will be doing, but they are all pretty much the same as the one I am using for the example here. The example I used has names, and all the other columns will be all text as well.

I found some examples on here (and google) of doing bits and parts of what I was looking for, but nothing that does it all in the fashion that I am attempting to do here. Help! :)

al6ovq.jpg
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

How about
Code: 
Sub getTally()

   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      If Not Dic.exists(Cl.Value) Then
         Dic.Add Cl.Value, 1
      Else
         Dic.Item(Cl.Value) = Dic.Item(Cl.Value) + 1
      End If
   Next Cl
   For Each Ky In Dic.keys
      Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Ky, Dic(Ky))
   Next Ky
End Sub
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Fluff said:
How about
Click to expand...

THats perfect. Thank you!

Now, can I sort the results all in the same sequence, or do I need to make that a separate event? Thanks again. Fluff
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Forgot about the sort. How about
Code: 
Sub getTally()

   Dim Cl As Range
   Dim i As Long, j As Long
   Dim Ary, Temp1, Temp2
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, 1
         Else
            .Item(Cl.Value) = .Item(Cl.Value) + 1
         End If
      Next Cl
      ReDim Ary(0 To .Count - 1, 0 To 1)
      For i = 0 To .Count - 1
         Ary(i, 0) = .Keys()(i)
         Ary(i, 1) = .Items()(i)
      Next i
   End With
   For i = LBound(Ary, 1) To UBound(Ary, 1) - 1
      For j = i + 1 To UBound(Ary, 1)
         If Ary(i, 1) < Ary(j, 1) Then
            Temp1 = Ary(j, 0)
            Temp2 = Ary(j, 1)
            Ary(j, 0) = Ary(i, 0)
            Ary(j, 1) = Ary(i, 1)
            Ary(i, 0) = Temp1
            Ary(i, 1) = Temp2
         End If
      Next j
   Next i
   Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Ary) + 1, 2).Value = Ary
End Sub
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Fluff said:
Forgot about the sort. How about
Click to expand...

Thank you! I just got it figured out myself. (yours is proabbly a better way to go tho. I just recorded a macro and then changed it some in order to capture the changing list of rows instead of having a set amount of rows. Going to insert yours now and see how it works.) Thanks again!! :)
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Fluff said:
Forgot about the sort. How about
Click to expand...

btw: Here is the code i ended up wiht after revising it to include other columns (like I said, I need to have it run the calculation on 9 or 10 columns when the workbook is opened) and with the sorting function thrown in too for the 2 columns now: (Is this the best way of going about this seeing that I have several other columns that I will be adding to the mix here? Or would it be better (simpler/faster) to go with what you suggested and revise it in order to adapt to adding multiple columns to it? THank you again for your help. I'm still very much a novice at VBA but I do love learning as much about it as I can.)

Code: 
Private Sub CommandButton1_Click()

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False

Dim Cl As Range
Dim Ky As Variant
   
Dim Dic As Object
Dim Cic As Object

Set Dic = CreateObject("scripting.dictionary")
Set Cic = CreateObject("scripting.dictionary")

For Each Cl In Range("A2", Range("A" & Rows.count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
      Dic.Add Cl.Value, 1
      Else
      Dic.Item(Cl.Value) = Dic.Item(Cl.Value) + 1
End If
      
Next Cl

For Each Ky In Dic.Keys
      Range("D" & Rows.count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Ky, Dic(Ky))
Next Ky

Dim Aa As Range
Dim Bb As Variant

For Each Aa In Range("B2", Range("B" & Rows.count).End(xlUp))
    If Not Cic.Exists(Aa.Value) Then
    Cic.Add Aa.Value, 1
    Else
    Cic.Item(Aa.Value) = Cic.Item(Aa.Value) + 1
    End If
        
Next Aa

For Each Bb In Cic.Keys
     Range("F" & Rows.count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Bb, Cic(Bb))
        
Next Bb
 
Dim rCol As Long
    rCol = ActiveSheet.UsedRange.Rows.count
    
    Range(Cells(2, 4), Cells(rCol, 5)).Select
    Range(Cells(2, 4), Cells(rCol, 5)).Activate
    
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range(Cells(2, 5), Cells(rCol, 5)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range(Cells(2, 4), Cells(rCol, 5))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Range(Cells(2, 6), Cells(rCol, 7)).Select
    Range(Cells(2, 6), Cells(rCol, 7)).Activate
    
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range(Cells(2, 7), Cells(rCol, 7)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range(Cells(2, 6), Cells(rCol, 7))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

For the dictionary part you could do
Code: 
   Dim Cl As Range
   Dim Ky As Variant
   Dim Dic As Object
   Dim i As Long
   Dim Cols As Variant
   
   Set Dic = CreateObject("scripting.dictionary")
   Cols = Array([COLOR=#ff0000]1[/COLOR], [COLOR=#0000ff]4[/COLOR], [COLOR=#ff0000]2[/COLOR], [COLOR=#0000ff]6[/COLOR])
   For i = 0 To UBound(Cols) Step 2
      For Each Cl In Range(Cells(2, Cols(i)), Cells(Rows.Count, Cols(i)).End(xlUp))
         If Not Dic.Exists(Cl.Value) Then
            Dic.Add Cl.Value, 1
         Else
            Dic.Item(Cl.Value) = Dic.Item(Cl.Value) + 1
         End If
      Next Cl
      For Each Ky In Dic.Keys
         Cells(Rows.Count, Cols(i + 1)).End(xlUp).Offset(1).Resize(, 2).Value = Array(Ky, Dic(Ky))
      Next Ky
      Dic.RemoveAll
   Next i
Where the values in red are the columns you want to look at & the values in blue are where you want the results
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Fluff said:
For the dictionary part you could do
Click to expand...

Does the newest code you just posted REPLACE part of the other one, or is this all new code? (I cant get it to work either way, so I thought I better ask. lol)
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

It replaces this section
Code: 
Dim Cl As Range
Dim Ky As Variant
   
Dim Dic As Object
Dim Cic As Object

Set Dic = CreateObject("scripting.dictionary")
Set Cic = CreateObject("scripting.dictionary")

For Each Cl In Range("A2", Range("A" & Rows.count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
      Dic.Add Cl.Value, 1
      Else
      Dic.Item(Cl.Value) = Dic.Item(Cl.Value) + 1
End If
      
Next Cl

For Each Ky In Dic.Keys
      Range("D" & Rows.count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Ky, Dic(Ky))
Next Ky

Dim Aa As Range
Dim Bb As Variant

For Each Aa In Range("B2", Range("B" & Rows.count).End(xlUp))
    If Not Cic.Exists(Aa.Value) Then
    Cic.Add Aa.Value, 1
    Else
    Cic.Item(Aa.Value) = Cic.Item(Aa.Value) + 1
    End If
        
Next Aa

For Each Bb In Cic.Keys
     Range("F" & Rows.count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Bb, Cic(Bb))
        
Next Bb
of the code you supplied in post#6
 
Upvote 0
Re: pls help; need code for: (1) counting unique & duplicate values in a column, (2) display the results somewhere, (3) sort them .

Fluff said:
It replaces this section
Click to expand...

OK. Got it.

Last question... (I hope):

Im having trouble using the code when referencing another sheet (within same workbook)

Original code you supplied is:

Code: 
Dim Cl As Range
Dim i As Long, j As Long
Dim Ary, Temp1, Temp2
 
With CreateObject("scripting.dictionary")
[B]For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))[/B]

This gives me error 1004:

Code: 
Dim Cl As Range
Dim i As Long, j As Long
Dim Ary, Temp1, Temp2
 
With CreateObject("scripting.dictionary")
[B]For Each Cl In Worksheets (“Sheet1”).Range("A2", Range("A" & Rows.Count).End(xlUp))[/B]
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
Counting instances of unique entries, with conditions
Replies
1
Views
405
ollyhughes1982
O
O
  • Solved
unique, sort, top 5
Replies
6
Views
167
Fluff
Fluff
D
  • Question
Results by handicap - with ties. Look up by score without duplicates
Replies
4
Views
124
dkjonesau
D
A
  • Solved
VBA to compare columns on separate sheets for unique value and then extract row content of the unique value
2
Replies
10
Views
752
Starbel
S
D
  • Question
Copy the value of a cell onto another worksheet based on the dropdown selection
Replies
4
Views
149
mumps
mumps

Forum statistics

Threads
1,215,635
Messages
6,125,940
Members
449,275
Latest member
jacob_mcbride

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