VBA Assigning Array to Range and Writing to Sheet returning all zeros

Count Matches (Dictionary, CountIf, Array (Double-Loop))

• All three solutions do the same thing.
• Using them with some serious data, e.g. 1K uniques on 100K values (means e.g. 100M iterations in the array version) will reveal the efficiency of each code.
• But this is more about 2D one-based (one-column) arrays commonly used with (one-column) ranges.
• The code is basic i.e. no blanks or error values are expected and each range has at least 2 cells
  (i.e. Data = rg.Value with one cell doesn't work).

Option Explicit


Sub ComparorDictionary()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read values (duplicates)
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vData() As Variant: vData = vws.Range("E1:E10").Value
    Dim vrCount As Long: vrCount = UBound(vData, 1)
    
    ' Count matches using a dictionary.
    
    Dim vDict As Object: Set vDict = CreateObject("Scripting.Dictionary")
    vDict.CompareMode = vbTextCompare
    
    Dim vr As Long
    
    For vr = 1 To vrCount
        vDict(vData(vr, 1)) = vDict(vData(vr, 1)) + 1
    Next vr
    
    Erase vData ' values data is counted in the dictionary
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Write count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim ur As Long
    
    For ur = 1 To urCount
        If vDict.Exists(uData(ur, 1)) Then
            uMatches(ur, 1) = vDict(uData(ur, 1))
        End If
    Next ur
    
    Set vDict = Nothing ' data is in the unique arrays
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub


Sub ComparorCountIf()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference values (duplicates). No array is needed.
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vrg As Range: Set vrg = vws.Range("E1:E10")
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Count matches and write the count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim ur As Long
    
    For ur = 1 To urCount
        uMatches(ur, 1) = Application.CountIf(vrg, uData(ur, 1))
    Next ur
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub


Sub ComparorArray()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read values (duplicates).
    Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
    Dim vData() As Variant: vData = vws.Range("E1:E10").Value
    Dim vrCount As Long: vrCount = UBound(vData, 1)
    
    ' Read uniques (no duplicates).
    Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
    Dim uData() As Variant: uData = uws.Range("E1:E10").Value
    Dim urCount As Long: urCount = UBound(uData, 1)
    
    ' Count matches and write the count.
    
    Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
    
    Dim vr As Long
    Dim ur As Long
    
    For ur = 1 To urCount
        For vr = 1 To vrCount
            If uData(ur, 1) = vData(vr, 1) Then
                uMatches(ur, 1) = uMatches(ur, 1) + 1
            End If
        Next vr
    Next ur
    
    Erase vData ' data is in the unique arrays
    
    ' Write result.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
    
    dws.Range("E1").Resize(urCount).Value = uData
    dws.Range("F1").Resize(urCount).Value = uMatches
    
End Sub

As I said in my comment, one of your declarations is wrong and because of that, the unexpected result. Please, try understanding the next (didactic) code, to clarify the issue:

Sub testArray1D2D()
   Dim arr1D, arr2DStrange, arr2D, i As Long
   arr1D = Split("a,b,c,d,e,f,g,h,i,j", ",")
   ReDim arr2DStrange(10, 1): ReDim arr2D(1 To 10, 1 To 1)
   For i = 0 To UBound(arr1D)
        arr2DStrange(i, 1) = arr1D(i)
        arr2D(i + 1, 1) = arr1D(i)
   Next i
   Range("A2").Resize(UBound(arr2DStrange), 1).value = arr2DStrange 'it returns nothing
   Range("B2").Resize(UBound(arr2DStrange), 2).value = arr2DStrange 'it returns what you need in the second column (D:D)
   Range("D2").Resize(UBound(arr2D), 1).value = arr2D 'it returns correctly (what you need)
   Range("E2").Resize(UBound(arr1D) + 1, 1).value = Application.Transpose(arr1D) 'also correct (a 1D array does not have any column! and it must be transposed. Otherwise, it repeats its first element value)
End Sub

When use declaration Dim test22(10, 1) As Integer it creates a 2D array but it has two columns. It is the equivalent of Dim test22(0 to 10, 0 to 1) As Integer. When you fill only the second column (1) and try returning the first one (0), this column, is empty.

The correct declaration for obtaining a 2D array with 10 rows and 1 column should be Dim test22(1 to 10, 1 to 1) As Integer.

Then, iTemp = CInt(UBound(dat1)) declares a 1D array of 11 elements (from 0, inclusive, to 10). And you never loaded its first element, starting iteration with 1. That's why the line Sheets("Info").Range("G1:G10").Value2 = NumMatches returned the first empty element 10 times... If your code would fill correctly the first element and if it was a matching one, your code will return 10 rows of 1 value.

NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1 is the equivalent of NumMatches(iCompareOuter) = 1. NumMatches(iCompareOuter) is always empty in that moment...

And it is good to cultivate the habit to avoid declarations As Integer in such a case. Working with Excel rows, the value of an Integer must be exceeded. Try using As Long. VBA is so designed to make the memory working in the same way, without any supplementary stress.

A more compact way to accomplish what you need will be the next approach:

Sub Comparor()
 Dim dat1(), dat2(), NumMatches(), mtch, i As Long

 dat1() = Sheets("Data1").Range("E1:E10").Value2
 dat2() = Sheets("Data2").Range("E1:E10").Value2
 ReDim NumMatches(1 To UBound(dat1), 1 To 1)

 For i = 1 To UBound(dat1)
    mtch = Application.match(dat1(i, 1), dat2, 0)
    If IsNumeric(mtch) Then NumMatches(i, 1) = "OK"
 Next i
 Sheets("Info").Range("G1:G10").Value2 = NumMatches
End Sub

Not tested, but it should work. Except the case of a typo, when an error will be raised and sending some feedback I will rapidly correct...

This for example

Dim test22(10, 1) As Integer

in the absence of Option Base 1 is the same as

Dim test22(0 to 10, 0 to 1) As Integer

I'd use

Dim test22(1 to 10, 1 to 1) As Integer

if you want to match the arrays you read from the worksheet. Otherwise, dropping those arrays to a range only gives you the first "column" (which are all zeros since you never assigned anything there...)