VBA - Array assign values For loop - excel

Question

I have to loop search multiple ranges and find match to 100k + records. Problem is I get mismatch error when assigning value to variant Arr2(i, 1).
Dim Arr1, Arr2 As Variant
Dim Wks0, Wks1 As Worksheet
Dim i As Integer
Dim Row0, Row1 As Long
Dim C As Object
Set Wks0 = Sheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")
'-- Create array of range -------------------------------------------*
Row0 = Wks0.Cells(Rows.Count, "A").End(xlUp).Row
Row1 = Wks1.Cells(Rows.Count, "A").End(xlUp).Row
Arr1 = Wks1.Range("A2:A" & Row1)
'-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
For i = 1 To 5 'UBound(Arr1)
With Wks0.Range("A2:A" & Row0)
Set C = .Find(Arr1(i, 1), LookAt:=xlPart,SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not C Is Nothing Then
'ReDim Preserve Arr2(i, 1)
Arr2(i, 1) = "OK"
Else
Arr2(i, 1) = "NO"
End If
End With
Next
' Transpose new array onto worksheet -------------------------------*
Wks1.Range("B2:B6") = WorksheetFunction.Transpose(Arr2)
'Arr1 = Nothing
'Arr2 = Nothing

Answer 1

I think you want to deal with a two-dimensioned array for the values coming in from wks1 (since you have no choice in the matter) and a single dimensioned array to hold the OK / NO values before stuffing them back into the worksheet.
Sub t()
Dim Arr0() As Variant, Arr1() As Variant, Arr2() As Variant
Dim Wks0 As Worksheet, Wks1 As Worksheet
Dim i As Long
Dim Row0 As Long, Row1 As Long
Dim C As Range
Set Wks0 = Sheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")
'-- Create array of range -------------------------------------------*
Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
Arr1 = Wks1.Range("A2:A" & Row1)
'-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
For i = 1 To UBound(Arr1, 1)
With Wks0.Range("A2:A" & Row0)
Set C = .Find(Arr1(i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
ReDim Preserve Arr2(i) '<~~ NOTE ReDim single dimensioned array here!
If Not C Is Nothing Then
Arr2(i) = "OK"
Else
Arr2(i) = "NO"
End If
End With
Next
' Transpose new array onto worksheet -------------------------------*
Wks1.Range("B2").Resize(UBound(Arr2), 1) = WorksheetFunction.Transpose(Arr2)
End Sub
Note where I've redimmed arr2. It's going to get a value either way so you need to extend its size in preparation to receive an OK / NO.
Scripting.Dictionary
Sub tt()
Dim arr As Variant, dHOST As Object
Dim Wks0 As Worksheet, Wks1 As Worksheet
Dim i As Long, j As Long
Dim Row0 As Long, Row1 As Long
Dim c As Range, rHOST As Range
Debug.Print Timer
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Wks0 = Worksheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")
Set dHOST = CreateObject("Scripting.Dictionary")
dHOST.CompareMode = vbTextCompare
'-- Create dictionary of HOST range --------------------------
Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
arr = Wks0.Range("A2:D" & Row0).Value2
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
'If Not dHOST.Exists(arr(i, j)) Then _
dHOST.Item(arr(i, j)) = j '<~~ for first match (adds 1½ seconds)
dHOST.Item(arr(i, j)) = j '<~~ for overwrite match
Next j
Next i
'-- Create array of OFICI_BANC_USA range ----------------------
Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
arr = Wks1.Range("A2:E" & Row1).Value2
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) + 1 To UBound(arr, 2)
arr(i, j) = "NO" '<~~ seed all NO matches
Next j
Next i
'-- Loop arrayed values from sheet OFIC_BANC_USA found value in dictionary HOST values --
For i = LBound(arr, 1) To UBound(arr, 1)
If dHOST.Exists(arr(i, 1)) Then _
arr(i, dHOST.Item(arr(i, 1)) + 1) = "OK"
Next i
' Stuff it all back into worksheet -------------------------------*
With Wks1.Range("A2:E" & Row1)
.Cells = arr
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
200K records in column A of OFICI_BANC_USA worksheet
4 columns # 50K rows each in HOSTS worksheet
~76% match rate
14.73 seconds start-to-finish

Answer 2

In addition to #VincentG's comment, you need to explicitly state which Rows you're using. Also, I uncommented the ReDim, and it seems to be working now:
Sub t()
Dim Arr0() As Variant, Arr1() As Variant, Arr2() As Variant
Dim Wks0 As Worksheet, Wks1 As Worksheet
Dim i As Integer
Dim Row0 As Long, Row1 As Long
Dim C As Object
Set Wks0 = Sheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")
'-- Create array of range -------------------------------------------*
Row0 = Wks0.Cells(Wks0.Rows.Count, "A").End(xlUp).Row
'Arr0 = Wks0.Range("A2:A" & Row0)
Row1 = Wks1.Cells(Wks1.Rows.Count, "A").End(xlUp).Row
Arr1 = Wks1.Range("A2:A" & Row1)
'-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
For i = 1 To 5 'UBound(Arr1)
With Wks0.Range("A2:A" & Row0)
Set C = .Find(Arr1(i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not C Is Nothing Then
ReDim Preserve Arr2(i, 1)
Arr2(i, 1) = "OK"
Else
Arr2(i, 1) = "NO"
End If
End With
Next
' Transpose new array onto worksheet -------------------------------*
Wks1.Range("B2:B6") = WorksheetFunction.Transpose(Arr2)
'Arr0 = Nothing
'Arr1 = Nothing
'Arr2 = Nothing
End Sub

Answer 3

I think I am understanding what you are trying to do. I set my two sheets up like this:
Then using the following code:
Sub jorge()
Application.ScreenUpdating = False
Dim Arr1 As Variant, Arr2 As Variant, Arr3 As Variant
Dim Wks0 As Worksheet, Wks1 As Worksheet
Dim i As Long, j As Long, k As Long
Dim Row0 As Long, Row1 As Long
Set Wks0 = Sheets("HOST")
Set Wks1 = Sheets("OFICI_BANC_USA")
'-- Create array of range -------------------------------------------*
Row0 = Wks0.Cells(Rows.Count, "A").End(xlUp).Row
Row1 = Wks1.Cells(Rows.Count, "A").End(xlUp).Row
Arr1 = Wks1.Range("A2:A" & Row1)
ReDim Arr2(1 To Row1, 1 To 4)
Arr3 = Wks0.Range("A2:D" & Row0)
'-- Loop create value on sheet OFIC_BANC_USA found value in sheet HOST -----*
For i = 1 To UBound(Arr1, 1)
For j = 1 To UBound(Arr3, 2)
Arr2(i, j) = "NO"
For k = 1 To UBound(Arr3, 1)
If Arr3(k, j) = Arr1(i, 1) Then
Arr2(i, j) = "OK"
Exit For
End If
Next k
Next j
Next i
Wks1.Range("B2").Resize(Row1, 4).value = Arr2
Application.ScreenUpdating = true
End Sub
I get this:
This formula will do the same thing, put this in B2:
=IF(ISNUMBER(MATCH($A2,HOST!A:A,0)),"OK","NO")
Copy across and down. This may be prohibitive with the sheer number of calculations, but it is here if you want to try it.