Multi-dimensional array to store and count occurrences of unique IDs - excel

Question

Background:
In trying to better understand dynamic multi-dimensional arrays, I am attempting to build one to capture unique values and count the occurrences of the unique values (something i should be able to verify pretty quickly with a countif).
In reading about trying to redim preserve a multidimensional array, I had read that you can only redim the last parameters, so I was attempting to set-up for 2 parameters, where the first is the unique value and the second is the count: arr(2,k). If my understanding is wrong, then that also is pretty significant.
The final output of the array I am throwing into column 3 (unique ID) and column 4 (# of occurrences).
Issue:
When adding values to the array, I am not able to collect all unique values. I have been able to collect 3 unique values, when there are 6 in the data, and the occurrences of each are staying at 1, e.g., not iterating.
Question:
I apologize that this is essentially 2 questions...
1) is my use of redim preserver arr(2,0 to k) appropriate syntax?
2) is there a glaring issue with my dynamic array generation which would explain why i'm not getting all unique values captured?
I could ask a third about why i can't get the occurrence count to work, but I am hopeful that if I understand the above issue I can hopefully struggle through this part.
What the data looks like:
All data is in Column A
cat
dog
mouse
cat
mouse
bear
frog
cat
moose
cat
dog
Code in Question:
Option Explicit
Private Sub unique_arr()
Dim arr As Variant, i As Long, lr As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(2, k)
For i = 1 To lr
If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then
ReDim Preserve arr(2, 0 To k)
arr(1, k) = Cells(i, 1).Value
arr(2, k) = 1
k = k + 1
Else
arr(2, Application.Match(Cells(i, 1), arr(1), 0)) = arr(2, Application.Match(Cells(i, 1), arr(1), 0)) + 1
End If
Next i
For i = LBound(arr) To UBound(arr)
Cells(i + 1, 3).Value = arr(1, i)
Cells(i + 1, 4).Value = arr(2, i)
Next i
End Sub

Answer 1

While you would be better off overall with a dictionary, there are a few things wrong with the If comparison.
If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then
VBA has its own IsError that returns True/False.
If IsError(Application.Match(Cells(i, 1).Value, arr, 0), 0)) Then
Additionally, arr is a 2-D array; in essence it has both rows and columns. The worksheet's Match can only work on a single column or a single row. You need to 'slice' off what you want with Index.
If Not IsError(Application.Match(Cells(i, 1).Value, application.index(arr, 1, 0), 0), 0)) Then
Finally, arr is defined as ReDim arr(2, k). This makes it arr(0 to 2, 0 to k) so there are three elements in the first rank (0, 1, 2), not 2. You never actually use the 0 in the first rank. It should be,
k = 1
ReDim arr(1 to 2, 1 to k)
Wind it all up and you end up with something like this.
Option Explicit
Private Sub unique_arr()
Dim i As Long, lr As Long, k As Long, arr As Variant, m As Variant
'assign values to some vars
lr = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
ReDim arr(1 To 2, 1 To k)
'loop through cells, finding duplicates and counting
For i = 1 To lr
m = Application.Match(Cells(i, 1).Value, Application.Index(arr, 1, 0), 0)
If IsError(m) Then
ReDim Preserve arr(1 To 2, 1 To k)
arr(1, k) = Cells(i, 1).Value
arr(2, k) = 1
k = k + 1
Else
arr(2, m) = arr(2, m) + 1
End If
Next i
'loop through array's second rank
For i = LBound(arr, 2) To UBound(arr, 2)
Cells(i, 3).Value = arr(1, i)
Cells(i, 4).Value = arr(2, i)
Next i
End Sub

Answer 2

For something like this, I'd use a Dictionary, like so:
Sub ExtractUniqueCounts()
Dim ws As Worksheet
Dim rCell As Range
Dim hUnq As Object
Set ws = ActiveWorkbook.ActiveSheet
Set hUnq = CreateObject("Scripting.Dictionary") 'Create Dictionary object
'Loop through populated cells in column A
For Each rCell In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Cells
'Ignore blanks
If Len(rCell.Value) > 0 Then
'Check if this is a new, unique value that hasn't been added yet
If Not hUnq.Exists(rCell.Value) Then
'New unique value found, add to dictionary and set count to 1
hUnq(rCell.Value) = 1
Else
'Not a unique value, increase existing count
hUnq(rCell.Value) = hUnq(rCell.Value) + 1
End If
End If
Next rCell
'Check if there are any results
If hUnq.Count > 0 Then
'Results found
'Output the keys (unique values)
ws.Range("C1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.keys)
'Output the values of the keys (the counts in this case)
ws.Range("D1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.items)
Else
'No results, return error
MsgBox "No data"
End If
End Sub