Referencing a particular cell value when there are two string matches in VBA

Question

I am trying to create a predictive algorithm in VBA that would search for strings in a particular row from a data source, and return a value based on the row number. This is the first step in the workflow, and in its simplest form, there are 2 tables as shown below:

Source Table:

Output Table:

This is what I'm trying to do:

1. Pick up the strings in Row 1 of Output Table (Blue,Black) and search for them in Rows 1,2,3,4 of Source Table.

2. If both strings match in a single row, the 'Input' cell from that particular row is copied to Row 1 in Output Table in the 'Output' column.

Example (2nd iteration): From Output Table Row 2, strings Ivory,Green,Grey are picked up and queried in all rows of Source Table. If any 2 out of 3 strings match in a single row on Source Table, the Input cell of that row is copied.

In this case, Ivory and Green match in Row 1, and also in Row 4. Either input cell would work, but for the sake of having a rule, lets take the last match (Row 4). So '1,8' would be copied to Row 2 on Output Table.

This the flow I am currently using, but I'm getting an incorrect output:

For i = 2 To 5
For j = 1 To 4
For k = 2 To 5
For l = 1 To 5

If Cells(i, j).Value = Worksheets("SourceTable").Cells(k, l).Value And Cells(i,j).Value <> "" Then
For a = 1 To 5
For b = 1 To 4

If Cells(i, b).Value = Worksheets("SourceTable").Cells(k, a).Value And Cells(i, b).Value <> "" Then
Cells(i, 15).Value = Worksheets("SourceTable").Cells(k, 5).Value
GoTo iLoop
End If

Next b
Next a
End If

Next l
Next k
Next j
iLoop:
Next i

Both tables would have around half a million rows, and I am trying to figure out how to reduce the number of loops and make it work at the same time. Any suggestions would be appreciated, this would help me save a lot of man-hours and automate a major chunk of the process. Thanks!

Answer 1

you can try this

Option Explicit

Sub main()
    Dim row As Range

    With Worksheets("OutputTable")
        For Each row In .Range("D2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "D" to "OutputTable" sheet last "col" column index (i.e. the one before "Output" column)
            SearchSource row
        Next
    End With
End Sub

Sub SearchSource(rng As Range)
    Dim cell As Range, row As Range
    Dim nFounds As Long

    With Worksheets("SourceTable")
        For Each row In .Range("E2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "E" to "SourceTable" sheet last "col" column index (i.e. the one before "Input" column)
            nFounds = 0
            For Each cell In rng.SpecialCells(xlCellTypeConstants)
                If Not row.Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then nFounds = nFounds + 1
                If nFounds = 2 Then Exit For
            Next
            If nFounds = 2 Then rng.Cells(, rng.Columns.count + 1).Value = row.Cells(, row.Columns.count + 1).Value
        Next
    End With
End Sub

Answer 2

'Try this:

'First declare some variables:

'the number of rows of the Output table

 Dim OrNum as integer 

'the number of columns of the Output table

 Dim OcNum as integer

'the number of rows of the Source table

 Dim SrNum as integer

'the number of columns of the Source table

 Dim ScNum as integer

'some dummy variables for the loops

 Dim rO as integer, cO as integer 

 Dim rS as integer, cS as integer 

And then declare a boolean variable (just for later on)

Dim bool as boolean 

'Then assume the output table has it's first cell at the most 'top and the most left of the output table, which is taken to 'be the cell Z1 in the following Code

'Begin with this first cell of the Output table and get each 'value in a way, that you move first (inner loop) over the 'columns by fixing the row Index (rO) of the Output table and then (outer loop) get down to each and every row like this:

For rO = 0 to OrNum - 1
    For cO = 0 to OcNum - 1
       Range("Z1").Offset(rO, cO)
    Next 
Next 

'Now you don't have only strings so you will need to check, 'if the value in the cell is a string or a number. There is VBA 'function, that can help. It's called IsNumeric. It will give 'True if the value is a numeric value. If we have a string, then it will give False. With the Function IsEmpty() you can also check if a cell is empty or not. If a cell is empty, then the function IsEmpty will return True.

For rO = 0 to OrNum - 1
     For cO = 0 to OcNum - 1
     bool = IsNumeric(Range("Z1").Offset(rO, cO).Value)
     bool = bool Or IsEmpty (Range("Z1").Offset(rO, cO).Value)
         If bool=False then 
 'we have a string!
 'do something 
          End if
      Next 
Next 

Answer 3

Sub macro()
lastRowOut = Sheets("OutputTable").Range("A" & Rows.Count).End(xlUp).Row
lastRowSou = Sheets("SourceTable").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRowOut
    For j = 2 To lastRowSou
        If checkRow(j, i) >= 2 Then
            Sheets("OutputTable").Cells(i, 5) = Sheets("SourceTable").Cells(j, 6)
            Exit For
        End If
    Next j
Next i
End Sub
Function checkRow(sRow, i)
lastCol = Split(Sheets("OutputTable").Cells(i, Columns.Count).End(xlToLeft).Address, "$")(1)
counter = 0
For Each cell In Sheets("OutputTable").Range("A" & i & ":" & lastCol & i)
    If Not Sheets("SourceTable").Range("A" & sRow & ":" & "E" & sRow).Find(cell.Value) Is Nothing Then
        counter = counter + 1
    End If
Next cell
checkRow = counter
End Function

Quite a few things are unclear so here were the assumptions I made:

• Two or more of the cells in a row in the OutputTable have to be matched for the prediction to be made.
• The first rows of both the Output and Source sheet contain "Col1, Col2" etc.
• You seem to not mind whether we use the first or last matching row (from the source sheet) so I went with the first.
  That's 3 loops instead of 6..