Excel VBA to count and print single values

Question

I need to count the number of different values ​​from a column and print it with a separate value and counter on another sheet. I work with this piece of code, but for some reason it does not return any result. Can someone tell me where I missed this piece!

Dim rngData As Range Dim rngCell As Range Dim colWords As Collection Dim vntWord As Variant Dim Sh As Worksheet Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet On Error Resume Next Set Sh1 = Worksheets("A") Set Sh2 = Worksheets("B") Set Sh3 = Worksheets("C") Sh1.Range("A2:B650000").Delete Set Sh = Worksheets("A") Set r = Sh.AutoFilter.Range r.AutoFilter Field:=24 r.AutoFilter Field:=24, Criteria1:="My Criteria" Sh1.Range("A2:B650000").Delete Set colWords = New Collection Dim lRow1 As Long lRow1 = <some number> Set rngData = <desired range> For Each rngCell In rngData.Cells colWords.Add colWords.Count + 1, rngCell.Value With Sh1.Cells(1 + colWords(rngCell.Value), 1) .Value = rngCell.Value .Offset(0, 1) = .Offset(0, 1) + 1 End With Next 

Above is my full code. My desired result is simple, count the number of occurrences of each cell in a column and print it on another sheet with an occurrence counter. Thanks!

Thanks! Navs.

Answer 1

It is very easy and practical using the dictionary. The logic is similar to Kittoes answer, but the object dictionary is much faster, more efficient, and you can output an array of all the keys and elements that you want to do here. I have simplified the code to create a list from column A, but you will get this idea.

 Sub UniqueReport() Dim dict As Object Set dict = CreateObject("scripting.dictionary") Dim varray As Variant, element As Variant varray = Range("A1:A10").Value 'Generate unique list and count For Each element In varray If dict.exists(element) Then dict.Item(element) = dict.Item(element) + 1 Else dict.Add element, 1 End If Next 'Paste report somewhere Sheet2.Range("A1").Resize(dict.Count, 1).Value = _ WorksheetFunction.Transpose(dict.keys) Sheet2.Range("B1").Resize(dict.Count, 1).Value = _ WorksheetFunction.Transpose(dict.items) End Sub 

How it works : you just give the range to an array of options to scroll quickly, and then add them to the dictionary. If it exists, you simply take the element that goes with it (starts at 1) and adds it to it. Then at the end just delete the unique list and the counts where you need it. Please note that the way to create an object for the dictionary allows you to use it - there is no need to add a link to your code.

Answer 2

Not the most beautiful or the most optimal route, but it will do its job, and I'm sure you can understand this:

 Option Explicit Sub TestCount() Dim rngCell As Range Dim arrWords() As String, arrCounts() As Integer Dim bExists As Boolean Dim i As Integer, j As Integer ReDim arrWords(0) For Each rngCell In ThisWorkbook.Sheets("Sheet1").Range("A1:A20") bExists = False If rngCell <> "" Then For i = 0 To UBound(arrWords) If arrWords(i) = rngCell.Value Then bExists = True arrCounts(i) = arrCounts(i) + 1 End If Next i If bExists = False Then ReDim Preserve arrWords(j) ReDim Preserve arrCounts(j) arrWords(j) = rngCell.Value arrCounts(j) = 1 j = j + 1 End If End If Next For i = LBound(arrWords) To UBound(arrWords) Debug.Print arrWords(i) & ", " & arrCounts(i) Next i End Sub 

This will go through A1: A20 to "Sheet1". If the cell is not empty, it checks to see if the word exists in the array. If not, then it adds it to the array with a count of 1. If it exists, it just adds 1 to the count. Hope this fits your needs.

Also, you just need to keep in mind when looking at your code: you should NEVER use On Error Resume Next .