[VBA] Use one Array to search through a second Array?

[Safety]

I have a tricky VBA question concerning Arrays (or possibly Collections): I would like to use two values located on the same row from Array1 (Sheet1) to search for the first instance of those same two values on the same row found in Array2 (Sheet2).

1) find the first instance of two values on the same row (Apple + Pie, Kiwi + Tart, Apple + Tart and Peach + Pie) from Array1 within Array2 on Sheet2
2) copy a value in a cell adjacent to that match from Sheet2 to Sheet1
3) delete the entire row on Sheet2 that contained the match to prevent repeats
4) continue the search using the values found in Array1 on Sheet1

I have a workbook with two sheets.

Sheet1 contains an array populated with data from Columns A & B:

[COLOR=SeaGreen]Column A[/COLOR] | [COLOR=Sienna]Column B[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]
  [COLOR=SeaGreen]Kiwi[/COLOR]   |   [COLOR=Sienna]Tart[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Tart[/COLOR]
  [COLOR=SeaGreen]Peach[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]

Sheet2 also contains an array populated with data from Columns A & B:

[COLOR=SeaGreen]Column A[/COLOR] | [COLOR=Sienna]Column B[/COLOR] | [COLOR=Blue]Column E[/COLOR]
  [COLOR=SeaGreen]Cherry[/COLOR] |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Blue]Zebra[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie [/COLOR]   |  [COLOR=Blue]Lion[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Tart[/COLOR]   |  [COLOR=Blue]Giraffe[/COLOR]
  [COLOR=SeaGreen]Peach[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Blue]Gazelle[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Blue]Elephant[/COLOR]

For example, the Macro would look for the first row which contains the terms Apple and Pie. It copy the value from Column E from Sheet2 over to the corresponding row in Sheet1, Column C. Finally it would delete the matched row from Sheet2 and continue searching for the remaining values in Array1 (Apple + Pie, Kiwi + Tart, Apple + Tart and Peach + Pie).

After running the macro, Sheet1 should appear as follows:

[COLOR=SeaGreen]Column A[/COLOR] | [COLOR=Sienna]Column B[/COLOR] | [COLOR=Purple]Column C[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie [/COLOR]   |  [COLOR=Purple]Lion[/COLOR]
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Purple]Elephant[/COLOR]
  [COLOR=SeaGreen]Kiwi[/COLOR]   |   [COLOR=Sienna]Tart   |[/COLOR] << Empty because 'Kiwi Tart' was not found in Array2
  [COLOR=SeaGreen]Apple[/COLOR]  |   [COLOR=Sienna]Tart[/COLOR]   |  [COLOR=Purple]Giraffe[/COLOR]
  [COLOR=SeaGreen]Peach[/COLOR]  |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Purple]Gazelle[/COLOR]

And Sheet2 would appear as follows since all but Cherry | Pie | Zebra were found and their rows were deleted:

[COLOR=SeaGreen]Column A[/COLOR] | [COLOR=Sienna]Column B[/COLOR] | [COLOR=Blue]Column E[/COLOR]
  [COLOR=SeaGreen]Cherry[/COLOR] |   [COLOR=Sienna]Pie[/COLOR]    |  [COLOR=Blue]Zebra[/COLOR]

***
I'm not sure how to determine what row an array element resides. For example a search for Peach + Pie in array2 might tell me that both terms exists on the same row but how can I tell that both values are located on Row 6?

Any suggestions would be greatly appreciated!
​

 

[mikerickson]

I think this will do what you want

Sub test()
    Dim ListOne As Range, ListTwo As Range
    Dim i As Long
    Dim rFormula As String, rFound As Variant
        
    With ThisWorkbook.Worksheets("Sheet1").Range("A:B")
        Set ListOne = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, .Columns.Count)
    End With
    
    With ThisWorkbook.Worksheets("Sheet2").Range("A:C")
        Set ListTwo = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, .Columns.Count)
    End With
   
    For i = 1 To ListOne.Rows.Count
        With ListTwo.EntireColumn
            Set ListTwo = Range(.Cells(ListTwo.Row, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, .Columns.Count)
        End With
        
        rFormula = Chr(34) & ListOne.Cells(i, 1).Value & Chr(34) & "&CHAR(5)&" & Chr(34) & ListOne.Cells(i, 2).Value & Chr(34)
        rFormula = "=MATCH(" & rFormula & "," & ListTwo.Columns(1).Address(, , , True)
        rFormula = rFormula & "&CHAR(5)&" & ListTwo.Columns(2).Address(, , , True)
        rFormula = rFormula & ",0)"
        rFound = Evaluate(rFormula)
        
        If IsNumeric(rFound) Then
            ListOne.Cells(i, 3).Value = ListTwo.Cells(rFound, 3).Value
            ListTwo.Rows(rFound).Delete shift:=xlUp
        End If
    Next i
End Sub

 

[bstory84]

Well since i started this earlier i will post my results.

Sub array_test()
Dim Sh1Arr() As Variant
Dim Sh2Arr() As Variant
Dim TempString1 As String
Dim TempString2 As String
    Sh1Arr = Sheet1.Range("A1:B5")
    Sh2Arr = Sheet2.Range("A1:C5")
For i = 1 To 5
 TempString1 = Sh1Arr(i, 1) & Sh1Arr(i, 2)
    For X = 1 To 5
        TempString2 = Sh2Arr(X, 1) & Sh2Arr(X, 2)
        If TempString1 = TempString2 Then
            Sheet1.Cells(i, 3) = Sh2Arr(X, 3)
           Sh2Arr(X, 1) = "Null"
           
            GoTo mFound
            
        Else
          
        End If
       Next X
mFound:
Next i
End Sub

hats off to you mikerickson, you are quick

 

[Safety]

Mike, bstory: Thank you very much for your help!

I'm embarrassed to admit that I've spent *days* trying to figure this out before posting. The fact you came up with a solution within minutes is humbling to say the least.

@Mike: One more question - How would you prevent a value in Sheet1, Column C from being overwritten if a value already exists in that cell?

If ((ListOne.Cells(i, 3).Value) <> "") Then
        End If
            ElseIf IsNumeric(rFound) Then
                ListOne.Cells(i, 3).Value = ListTwo.Cells(rFound, 3).Value
                ListTwo.Rows(rFound).Delete shift:=xlUp
            End If
    Next i
End Sub

 

[mikerickson]

I'd change this line.

If IsNumeric(rFound) And (ListOne.Cells(i, 3).Value = vbNullString) Then

However, that will prevent that row from being removed from List 2.

 

[Safety]

Mike, I learn something new every time you post. Thank you!

I just read up on the usage of vbNullString and why it should be used place of "".

However, that will prevent that row from being removed from List 2.

No problem at all. That was exactly what I needed.

Here is the updated section for others to use as reference:

If IsNumeric(rFound) And (ListOne.Cells(i, 3).Value = vbNullString) Then
                ListOne.Cells(i, 3).Value = ListTwo.Cells(rFound, 3).Value
                ListTwo.Rows(rFound).Delete shift:=xlUp
            ElseIf IsNumeric(rFound) And (LenB(ListOne.Cells(i, 3).Value) >= 1) Then
            End If
    Next i
End Sub

I'm still amazed by this section from your first reply. Mainly because of the thought process behind it, the use of Chr() and .Address. I could have stared at the reference guide for a year and still wounldn't have hacked this together.

        rFormula = Chr(34) & ListOne.Cells(i, 1).Value & Chr(34) & "&CHAR(5)&" & Chr(34) & ListOne.Cells(i, 2).Value & Chr(34)
        rFormula = "=MATCH(" & rFormula & "," & ListTwo.Columns(1).Address(, , , True)
        rFormula = rFormula & "&CHAR(5)&" & ListTwo.Columns(2).Address(, , , True)
        rFormula = rFormula & ",0)"
        rFound = Evaluate(rFormula)

Thanks again for your help!

 

[mikerickson]

I could have used this formulation instead (and many folks do).

rFormula = """" & ListOne.Cells(i, 1).Value & """&CHAR(5)&""" & Chr(34) & ListOne.Cells(i, 2).Value & """"

but I find it easier to figure out what is going on by using Chr(34) rather than counting double quotes.

 

[Safety]

I'm sorry to bother you again Mike but I have one more question:

I've made a few changes which somehow prevent the script from processing the last row in both ranges (ListOne and ListTwo). The changes were to add the ability to process non-contiguous ranges (Columns B + D on Sheet1, Columns A,C + E on Sheet2).

I've tried the following but none have solved the issue:

- Added +1 to ListOne.Rows.Count (adding 1 or 25 doesn't change the behavior):
- Resized the ranges defined in ListOne and ListTwo by one row (Ranges now start on row 2 to exclude headers).
- Offset the ranges down by one row after setting the range to start at row 1 instead of row 2.

Here is the latest version of the script and 'Thanks!' again for your help

Sub Test()
    Dim ListOne As Range, ListTwo As Range
    Dim i As Long
    Dim PlusOne As Long, rFormula As String, rFound As Variant
    
    With ThisWorkbook.Worksheets("Sheet1")
        StartRange = "B2"
        MidRange = "D2"
            
            Set a = .Range(StartRange, .Range(StartRange).End(xlDown))
            Set b = .Range(MidRange, .Range(MidRange).End(xlDown))
        
        Set ListOne = Union(a, b)

    End With
        
    With ThisWorkbook.Worksheets("Sheet2")
        TratsRange = "A2"
        DimRange = "C2"
        DneRange = "E2"
            
            Set d = .Range(TratsRange, .Range(TratsRange).End(xlDown))
            Set e = .Range(DimRange, .Range(DimRange).End(xlDown))
            Set f = .Range(DneRange, .Range(DneRange).End(xlDown))
        
        Set ListTwo = Union(d, e, f)

    End With
   
    For i = 1 To ListOne.Rows.Count
        With ListTwo.EntireColumn
            Set ListTwo = Range(.Cells(ListTwo.Row, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, .Columns.Count)
        End With
        
        rFormula = Chr(34) & ListOne.Cells(i, 1).Value & Chr(34) & "&CHAR(5)&" & Chr(34) & ListOne.Cells(i, 3).Value & Chr(34)
        rFormula = "=MATCH(" & rFormula & "," & ListTwo.Columns(1).Address(, , , True)
        rFormula = rFormula & "&CHAR(5)&" & ListTwo.Columns(3).Address(, , , True)
        rFormula = rFormula & ",0)"
        rFound = Evaluate(rFormula)
        
            If IsNumeric(rFound) And (ListOne.Cells(i, 5).Value = vbNullString) Then
                ListOne.Cells(i, 5).Value = ListTwo.Cells(rFound, 5).Value
                ListTwo.Rows(rFound).EntireRow.Delete shift:=xlUp
            ElseIf IsNumeric(rFound) And (LenB(ListOne.Cells(i, 5).Value) >= 1) Then
            End If
    Next i
End Sub

 

[mikerickson]

Many properties (like .Row) work oddly when applied to a discontinous range.

I haven't looked closely at your modification, but a loop (loops?) through the .Areas of a discontinous range is ususaly the fix for that kind of problem.