Visual Basic for Applications (VBA) Count Unique Cells - vba

Question

I'm attempting to make a Visual Basic Macro to count unique items in a row without doing the copy and pasting and data remove duplicates.
For some reason I'm having issues with my syntax. When I run the script it outputs with the number of rows.
This is my first time programming in Visual Basic for Applications (VBA).
Private Sub FrequencyCount_Click()
Dim rng As Range
Dim outcell As Range
Dim outnum As Integer
Dim MyArray() As Variant
Dim ArrayLength As Integer
Dim unique As Boolean
Dim i
outnum = 0
ArrayLength = 1
unique = False
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
For Each B In rng.Rows
If outnum = 0 Then
ReDim MyArray(1)
MyArray(ArrayLength) = B.Value
outnum = outnum + 1
ArrayLength = ArrayLength + 1
Else
i = 0
unique = True
Do Until i < ArrayLength
If MyArray(i) = B.Value Then
unique = False
End If
i = i + 1
Loop
MsgBox unique
If unique = True Then
ReDim Preserve MyArray(0 To ArrayLength + 1)
MyArray(ArrayLength) = B.Value
ArrayLength = ArrayLength + 1
outnum = outnum + 1
End If
End If
Next
End
outcell.Value = outnum
End Sub

Answer 1

It is generally considered bad practice to ReDim Arrays in Loop and not recommended. If you search internet then many discussions like this will come up
ReDim in Loop
You can use built-in functionality to get where you want. Example code which should work for you.
Sub FrequencyCount_Click()
Dim rng As Range
Dim outcell As Range
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
rng.Copy outcell.Cells(1, 1)
outcell.Resize(rng.Cells.Count, 1).RemoveDuplicates 1, xlNo
End Sub

Answer 2

As #RyanWildry suggests, you can use the Dictionary object for this.
The code to call the procedure will also define the range containing the duplicates and the start range to paste the unique values to:
Sub Test()
'This will take values in the first range and paste the uniques starting at the second range cell.
'NB: Search for With...End With.
With ThisWorkbook.Worksheets("Sheet1")
FrequencyCount .Range("B2:B48"), .Range("D2")
End With
End Sub
This code will then place the values into a dictionary, which also removes any duplicates and then uses a couple of techniques to paste back into rows or columns.
I've added lots of comments and this link may help for further reading on the Dictionary object: https://excelmacromastery.com/vba-dictionary/
Public Sub FrequencyCount(SourceRange As Range, TargetRange As Range)
Dim oDict As Object
Dim rCell As Range
Dim vKey As Variant
Dim vArr As Variant
Dim x As Long
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = vbTextCompare 'Non-case sensitive. Use vbBinaryCompare to make case sensitive.
'Go through each cell in the source range and copy the value to the dictionary.
For Each rCell In SourceRange
'Change the value in the dictionary referenced by key value.
'If key value doesn't exist create it.
oDict(rCell.Value) = rCell.Value
Next rCell
'Paste in rows.
x = 1
ReDim vArr(1 To oDict.Count)
For Each vKey In oDict.Keys
vArr(x) = oDict(vKey)
x = x + 1
Next vKey
TargetRange.Resize(UBound(vArr)) = WorksheetFunction.Transpose(vArr)
'Paste in columns.
TargetRange.Resize(1, UBound(Application.Transpose(oDict.Keys))) = oDict.Keys
End Sub

Answer 3

The problem is you are setting i = 0 then saying
Do until i < arraylength`
Well if i = 0 then it will always be less than arraylength, this probably should be
Do until i > arraylength
Hope this helps :)

Answer 4

This is an more compact solution, I cobbled together from other solutions.
Sub UniqueCountinSelection()
Dim outcell As Range
Dim itms As Object, c As Range, k, tmp As String
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
Set itms = CreateObject("scripting.dictionary")
For Each c In rng
tmp = Trim(c.Value) 'removes leading and trailing spaces
If Len(tmp) > 0 Then itms(tmp) = itms(tmp) + 1
Next c
outcell.Value = UBound(itms.Keys) + 1
End Sub