VBA Comparing two 2D arrays (rows), VBA throws "Type mismatch", declarations ok

Question

Unsolvable mystery. I keep getting "Type mismatch" error at runtime.

I am trying to compare two 2D arrays, lifted from two different Sheets, to loop and compare "slices" of these arrays, row by row. If match is found, values from one array should be assigned to empty (null) indexes of the other array.

This is my code:

Private arrPlan() As Variant
Private lastRowSource As Long
Private lastColSource As Long

Private arrRawData() As Variant
Private lastRowDestination As Long
Private lastColDestination As Long


Public Sub Get_Plan_Into_RawData()

'---- Find last row/col and read Excel ranges into Arrays

lastRowSource = Sheet1.Range("A" & Rows.count).End(xlUp).Row
lastColSource = Sheet1.Range("A1").End(xlToRight).Column

lastColDestination = Sheet2.Range("A1").End(xlToRight).Column
lastRowDestination = Sheet2.Range("A" & Rows.count).End(xlUp).Row

arrPlan = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(lastRowSource, lastColSource))
arrRawData = Sheet2.Range(Sheet2.Cells(1, 1), Sheet2.Cells(lastRowDestination, lastColDestination))


'----- Compare arrays, assign amounts from one array to the other

For i = LBound(arrPlan, 1) + 1 To UBound(arrPlan, 1)
    For j = LBound(arrRawData, 1) + 1 To UBound(arrRawData, 1)

        If Application.WorksheetFunction.Index(arrPlan, i, Array(1, 2, 3, 4, 5)) = _
        Application.WorksheetFunction.Index(arrRawData, j, Array(1, 6, 7, 8, 10)) Then
            arrRawData(j, 12) = arrPlan(i, 6)
            arrRawData(j + 1, 12) = arrPlan(i, 7)
            arrRawData(j + 2, 12) = arrPlan(i, 8)
            arrRawData(j + 3, 12) = arrPlan(i, 9)
            arrRawData(j + 4, 12) = arrPlan(i, 10)
            arrRawData(j + 5, 12) = arrPlan(i, 11)
            arrRawData(j + 6, 12) = arrPlan(i, 12)
            arrRawData(j + 7, 12) = arrPlan(i, 13)
            arrRawData(j + 8, 12) = arrPlan(i, 14)
            arrRawData(j + 9, 12) = arrPlan(i, 15)
            arrRawData(j + 10, 12) = arrPlan(i, 16)
            arrRawData(j + 11, 12) = arrPlan(i, 17)
        GoTo 10
        End If
    Next j
10 Next i
End Sub

Here is the example of the first array 'arrPlan':

about 80 rows, 15 columns; strings and int's; no empty (null) values

Market  Channel Campaign  Product   Funding source  jan         feb         mar     apr     may     jun
Austria sem     np        A. v.     dp              1,078.14    658.24      703.85  10,504.94       9,631.14    10,345.06
Austria sem     np        Culture   dp              1,660.86    1,139.12    1,098.52    16,182.72   16,667.23   16,145.70

And here is the example of the second array 'arrRawData':

about 400,000 rows, 13 columns; strings and some empty (null) cells

Market      Code    Priority    Abbreviation    Translation Channel Campaign        Product             P. code     Funding src.    Month   plan NET
Austria     4       4           AT              Austrija    gdn     advent          Family vacation     0           bp              jan 
Austria     4       4           AT              Austrija    gdn     advent          Family vacation     0           bp              feb 

• Can it be that WorksheetFunction.Index does not work above certain row number?
• The "Empty" values in some indexes of 'arrRawData' present the problem?

The final goal is to get numbers (amounts form columns jan, feb, mar, ...) from arrPlan into the empty far right column 'plan NET' of the arrRawData array and write it all back to the Sheet.

Thanks for saving my sanity.

Answer 1

Try this modification using a Scripting.Dictionary object.

Public Sub Get_Plan_Into_RawData()
    Dim a As Long, d As Long, arrPlan As Variant, arrRawData As Variant
    Dim dPlan As Object

    Set dPlan = CreateObject("Scripting.Dictionary")
    dPlan.comparemode = vbTextCompare

    With Sheet1
        With .Cells(1, 1).CurrentRegion
            arrPlan = .Cells.Value2
        End With
        Debug.Print LBound(arrPlan, 1) & ":" & UBound(arrPlan, 1)
        Debug.Print LBound(arrPlan, 2) & ":" & UBound(arrPlan, 2)
        For d = LBound(arrPlan, 1) + 1 To UBound(arrPlan, 1)
            If Not dPlan.exists(Join(Array(arrPlan(d, 1), arrPlan(d, 2), arrPlan(d, 3), _
                                           arrPlan(d, 4), arrPlan(d, 5)), ChrW(8203))) Then
                dPlan.Add Key:=Join(Array(arrPlan(d, 1), arrPlan(d, 2), arrPlan(d, 3), _
                                          arrPlan(d, 4), arrPlan(d, 5)), ChrW(8203)), _
                          Item:=d
            End If
        Next d
    End With

    With Sheet2
        With .Cells(1, 1).CurrentRegion
            arrRawData = .Cells.Value2
        End With
        Debug.Print LBound(arrRawData, 1) & ":" & UBound(arrRawData, 1)
        Debug.Print LBound(arrRawData, 2) & ":" & UBound(arrRawData, 2)
    End With

    'a) cannot loop to the end if you are going to add 11
    'b) if you are putting values into 12 consecutive rows,
    '   then why not Step 12 on the increment
    For a = LBound(arrRawData, 1) + 1 To UBound(arrRawData, 1) - 11 Step 12
        If dPlan.exists(Join(Array(arrRawData(a, 1), arrRawData(a, 6), arrRawData(a, 7), _
                                   arrRawData(a, 8), arrRawData(a, 10)), ChrW(8203))) Then
            d = dPlan.Item(Join(Array(arrRawData(a, 1), arrRawData(a, 6), arrRawData(a, 7), _
                                   arrRawData(a, 8), arrRawData(a, 10)), ChrW(8203)))
            arrRawData(a, 12) = arrPlan(d, 6)
            arrRawData(a + 1, 12) = arrPlan(d, 7)
            arrRawData(a + 2, 12) = arrPlan(d, 8)
            arrRawData(a + 3, 12) = arrPlan(d, 9)
            arrRawData(a + 4, 12) = arrPlan(d, 10)
            arrRawData(a + 5, 12) = arrPlan(d, 11)
            arrRawData(a + 6, 12) = arrPlan(d, 12)
            arrRawData(a + 7, 12) = arrPlan(d, 13)
            arrRawData(a + 8, 12) = arrPlan(d, 14)
            arrRawData(a + 9, 12) = arrPlan(d, 15)
            arrRawData(a + 10, 12) = arrPlan(d, 16)
            arrRawData(a + 11, 12) = arrPlan(d, 17)
        End If
    Next a

    'put the revisions back
    With Sheet2
        .Cells(1, 1).Resize(UBound(arrRawData, 1), UBound(arrRawData, 2)) = arrRawData
    End With


    dPlan.RemoveAll: Set dPlan = Nothing

End Sub

When transferring the values, you were passing into successive 'rows' in the array but still trying to process to UBound(arrRawData, 1). The loop has to stop 11 short of the UBound or another Runtime error 9: Subscript out of range was going to occur when the +11 pushed past the UBound.

edit: - two modifications

1. The original method of populating the dictionary was an overwrite method but it occurred to me that you will always need the position of the first match. Changed the .Add method.
2. The loop through the larger array should be on a Step 12 increment since you are populating 12 consecutive rows with data on a match.

Answer 2

You can't compare two arrays using a single operation: you need to either loop over both and compare each pair of elements, or reduce both arrays to a single value.

E.g. using Join() -

Sub Test()

    Dim arrPlan, arrRawData, i, j, v1, v2

    Set arrPlan = Range("A3:J8")
    Set arrRawData = Range("A11:J16")

    i = 1
    j = 2

    v1 = Application.WorksheetFunction.Index(arrPlan, i, Array(1, 2, 3, 4, 5))

    v2 = Application.WorksheetFunction.Index(arrRawData, j, Array(1, 6, 7, 8, 10))

    If Join(v1, vbNull) = Join(v2, vbNull) Then

        Debug.Print "match!"

    End If

End Sub

Edit - since you have a lot of data, the approach below will be significantly faster. It creates a dictionary "map" for each range, each of which has "keys" composed of one or more columns in each range.

Finding row matches is then simple/fast as all you need to do is loop over the keys from one of the maps (loop over the smaller one) and call "exists" on the other (larger) map using each key.

Sub Test()

    Dim d1, d2, k
    Set d1 = RowMap(Range("A3:J8"), Array(1, 2, 3))
    Set d2 = RowMap(Range("A11:J16"), Array(8, 9, 10))

    Debug.Print d1.Count, d2.Count

    For Each k In d1.keys
        If d2.exists(k) Then
            Debug.Print "Found a match on " & k & ": " & _
                        d1(k).Address & " to " & d2(k).Address
        End If
    Next k

End Sub

'Get a "map" of row keys (composed of one or more columns) to the 
'    rows where they are located (just maps the first cell in each row)
' "rng" is the range to be mapped
' "arrcols" is an array of column numbers to use for the [composite] key
Function RowMap(rng As Range, arrCols)
    Dim rv, nr As Long, nc As Long, r As Long, c As Long
    Dim k, lbc As Long, ubc As Long, sep As String
    Dim data

    Set rv = CreateObject("scripting.dictionary")

    data = rng.Value
    lbc = LBound(arrCols)
    ubc = UBound(arrCols)

    For r = 1 To UBound(data, 1)
        sep = ""
        k = ""
        For c = lbc To ubc
            k = k & sep & data(r, arrCols(c))
            If c = lbc Then sep = Chr(0)
        Next c
        If rv.exists(k) Then
            Set rv(k) = Application.Union(rv(k), rng.Columns(1).Cells(r))
        Else
            rv.Add k, rng.Columns(1).Cells(r)
        End If
    Next r
    Set RowMap = rv
End Function