0 votes
in VBA by Beginner (6 points)
I would like to select a column that has multiplte values multiple times eg. 10 x the word "apple", 20 x the word "orange", etc. and have the data counted. That means to output a column next to this column, how many times each value is entered. The output should be like Apple = 10, Orange = 20, in the column next to the data.

Can someone help me with this?

3 Answers

+1 vote
by Skilled (741 points)
selected ago by
 
Best answer

Here is an improved version of my last macro:

Sub ListUnique() ' assume ActiveSheet
    Dim A As Variant, v As Variant
    Dim C As Collection, K As Collection, R As Range
    Dim dataLastRow As Long, outputRow As Long, n As Long
    
    Const dataColumn As Long = 1 ' data in column A
    Const outputColumn As Long = dataColumn + 1
    Const dataFirstRow As Long = 2 ' row 1 is header
    
    dataLastRow = Cells(Rows.Count, dataColumn).End(xlUp).Row
    Set R = Range(Cells(dataFirstRow, dataColumn), Cells(dataLastRow, dataColumn))
    A = R.Value ' array of data values
    Set C = New Collection ' unique items
    Set K = New Collection ' count of each unique item
    On Error Resume Next ' ignore error when adding repeated data value
        For Each v In A
            v = CStr(v)
            If v <> vbNullString Then
                Err.Clear
                C.Add Item:=v, Key:=v
                If Err = 0 Then
                    K.Add Item:=1, Key:=v
                Else
                    n = K.Item(v) + 1
                    K.Remove v
                    K.Add Item:=n, Key:=v
                End If
            End If
        Next v
    On Error GoTo 0
    outputRow = Cells(Rows.Count, outputColumn).End(xlUp).Row
    Range(Cells(dataFirstRow, outputColumn), Cells(outputRow, outputColumn)).Clear
    outputRow = dataFirstRow
    For Each v In C ' output results
        Cells(outputRow, outputColumn) = v & " = " & K.Item(v)
        outputRow = outputRow + 1
    Next v
End Sub

 

by Beginner (6 points)
thank-you!

amazing macro.
by Skilled (741 points)

To include blank cells in the count, delete this section:

            If v <> vbNullString Then
                Err.Clear
                C.Add Item:=v, Key:=v
                If Err = 0 Then
                    K.Add Item:=1, Key:=v
                Else
                    n = K.Item(v) + 1
                    K.Remove v
                    K.Add Item:=n, Key:=v
                End If
            End If

And replace it with this:

            If v = vbNullString Then v = "BlankCell"
            Err.Clear
            C.Add Item:=v, Key:=v
            If Err = 0 Then
                K.Add Item:=1, Key:=v
            Else
                n = K.Item(v) + 1
                K.Remove v
                K.Add Item:=n, Key:=v
            End If

 

by Skilled (741 points)

There is a bug near the end of the macro above. Replace this statement:

Range(Cells(dataFirstRow, outputColumn), Cells(outputRow, outputColumn)).Clear

with the following statements:

If outputRow >= dataFirstRow Then
    Range(Cells(dataFirstRow, outputColumn), Cells(outputRow, outputColumn)).Clear
End If

 

0 votes
by Skilled (741 points)
edited by

Assume your list with repeated values is in A2:A100. Put the list of unique values in B2:Bx. For your example, x=3, B2=apple, B3=orange. Or if you have the latest Excel 365, you can put this formula in B2: 
=UNIQUE(A2:A100)
Now put this formula in C2 and duplicate it down to Cx: 
=B2&" = "&COUNTIF(A2:A100,"="&B2)
Or if you want to capitalize the first letter in each word, use this formula in C2 and duplicate it down to Cx: 
=PROPER(B2)&" = "&COUNTIF(A2:A100,"="&B2)

by Beginner (6 points)
thank-you,

but seeing the list may have thousands of items, I need excel to count the distinct values, without making a b2:bx column as indicated.
by Skilled (741 points)
edited by
See my 2nd answer. If that works for you, please click the check-box or up-vote.
0 votes
by Skilled (741 points)

Try this macro:

Sub ListUnique() ' assume ActiveSheet
    Dim A As Variant, v As Variant, item As Variant
    Dim C As Collection, R As Range
    Dim dataLastRow As Long, outputRow As Long, n As Long
    
    Const dataColumn As Long = 1 ' data in column A
    Const outputColumn As Long = dataColumn + 1
    Const dataFirstRow As Long = 2 ' row 1 is header
    
    dataLastRow = Cells(Rows.Count, dataColumn).End(xlUp).Row
    Set R = Range(Cells(dataFirstRow, dataColumn), Cells(dataLastRow, dataColumn))
    A = R.Value ' array of data values
    Set C = New Collection
    On Error Resume Next ' ignore error when adding repeated data value
        For Each v In A
            v = CStr(v)
            If v <> vbNullString Then C.Add item:=v, Key:=v
        Next v
    On Error GoTo 0
    outputRow = dataFirstRow
    For Each item In C
        n = 0
        For Each v In A
            If CStr(v) = item Then n = n + 1
        Next v
        Cells(outputRow, outputColumn) = item & " = " & n
        outputRow = outputRow + 1
    Next item
End Sub

By the way, you might be interested in My Excel Toolbox.

by Skilled (741 points)
+1
See my 3rd answer for an improved version of the macro.
by Beginner (6 points)
hi,

could you please include the counting of blank cells as well?

thanks,
by Skilled (741 points)
+1
See comment about blank cells after my 3rd answer.
by Beginner (6 points)
thanks again,you made my day!

After seeing the macro in action, I couldn't help but think of some improvements, which would make this a killer macro, maybe good enough for your toolbox!!

1) instead of the result being displayed by the "value" x "number", I would put the values in one column under the heading of "ITEMS" and the number in an ajacent column under the heading of "COUNT". This lets you sort the number from big to small etc.

2) the macro can ask "Which column would you like to count the number of distinct values?", then based on the letter of the column, it would perform.

How to do this?
by Skilled (741 points)

Re. #1 in your comment above, the macro's output is specified in your original question. But I agree it would be better if separated into two columns. See the Range.Offset property, which is similar to Excel's OFFSET function.

Re. #2, see VBA's InputBox function or Excel's Application.InputBox method.

by Skilled (741 points)
See comment about bug correction after my 3rd answer.

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

ParserMonster $25 Amazon Gift Card
Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.

Register

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...