Search in a Cell and Return Associate Value

[kparadise]

Hello,

I have two tabs. [TAB1] is where I want to place my results. I want the results starting in columns C and moving right, as many columns as need be. I am hoping I can limit the columns the results section will be by only returning unique results (i.e. if there are three reference IDs that are "Red", I only want to return "Red" one time - if this cannot be done, that is ok too).

So, what I am trying to do is to look into each cell in column A on [TAB1], and search for the values in [TAB2] Column A; and then return values from [TAB2] Column B into [TAB1] Column C. Each record in [TAB1] can have multiple values, special characters, return signs, etc.

TAB1	A	B	C	D	E	F
1	REF	ID	Results	Results	Results	Results
2	~LL_123 - this is a test ~LL_125 - this is also a test	A1	Red	Blue
3	~LL_9999 - testing testing	A2	Yellow
4	~LL_9999 - testing testing ~LL_123 - this is a test ~LL_124 - hello testing ~LL_315 - can you hear me	A3	Yellow	Red	Blue
5	~LL_123 - this is a test ~LL_2362 - yikes ~LL_9998 - test please	A4	Red
6	~LL_5555	A5

<tbody>
</tbody>

TAB2	A	B
1	REF	VALUE
2	LL_123	Red
3	LL_124	Blue
4	LL_125	Blue
5	LL_2094	Green
6	LL_2363	Red
7	LL_315	Blue
8	LL_9999	Yellow
9	LL_9998	Red

<tbody>
</tbody>

 

[shknbk2]

Here's what I came up with based on your example data:

Sub SearchAndReturn()
    Dim Tab1RefRange As Range, Tab2RefRange As Range
    Dim Tab1RefArray As Variant, Tab1ResultsArray() As Variant
    Dim Tab2Array As Variant, i As Long, j As Long, k As Long, m As Integer
    Dim ResultsExists As Boolean
    
    With Worksheets("TAB1")
        If .Range("A2").Value <> "" Then
            Set Tab1RefRange = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
        Else
            MsgBox "TAB1 cell A2 is empty."
            Exit Sub
        End If
    End With
    
    With Worksheets("TAB2")
        If .Range("A2").Value <> "" Then
            Set Tab2RefRange = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp))
        Else
            MsgBox "TAB2 cell A2 is empty."
            Exit Sub
        End If
    End With
    
    Tab1RefArray = Tab1RefRange.Value
    Tab2Array = Tab2RefRange.Value
    
    For i = 1 To UBound(Tab1RefArray, 1)
        k = 0
        For j = 1 To UBound(Tab2Array, 1)
            If InStr(1, Tab1RefArray(i, 1), Tab2Array(j, 1)) > 0 Then
                If k = 0 Then
                    k = 1
                    ReDim Tab1ResultsArray(1 To 1, 1 To k)
                    Tab1ResultsArray(1, k) = Tab2Array(j, 2)
                Else
                    ResultsExists = False
                    For m = 1 To k
                        If Tab1ResultsArray(1, m) = Tab2Array(j, 2) Then
                            ResultsExists = True
                            Exit For
                        End If
                    Next m
                    If Not ResultsExists Then
                        k = k + 1
                        ReDim Preserve Tab1ResultsArray(1 To 1, 1 To k)
                        Tab1ResultsArray(1, k) = Tab2Array(j, 2)
                    End If
                End If
            End If
        Next j
        If k > 0 Then
            Tab1RefRange.Cells(i, 1).Offset(0, 2).Resize(1, k).Value = Tab1ResultsArray
        End If
    Next i
End Sub

 

[kparadise]

This works great, I am just having trouble implementing it to my actual spreadsheet.

1. Can you adjust the code a bit to the following. Can we search for the header named "REF" in Tab1; because this is an adhoc report, and it might not always be in column A on TAB1....it could be column A-ZZ.
2. Can you start the results after the last column in TAB1. Because this is an adhoc report, sometimes TAB1 will have 4 columns, sometimes it will have 30 columns...I just want the results to start after the last column with a header.

 

[shknbk2]

Sure. Here is what I came up with. Note that it creates new results columns and doesn't delete any previous ones. So, if you run this twice, you'll get two sets of results columns side-by-side.

Sub SearchAndReturn()
    Dim Tab1RefRange As Range, Tab2RefRange As Range, Tab1ResultsRange As Range
    Dim Tab1RefArray As Variant, Tab1ResultsArray() As Variant
    Dim Tab2Array As Variant, i As Long, j As Long, k As Long, m As Integer
    Dim ResultsExists As Boolean, iResults As Integer
    
    With Worksheets("TAB1")
        Set Tab1RefRange = FindREF(.UsedRange, "REF")
        If Tab1RefRange Is Nothing Then
            MsgBox "Can't find 'REF' column on TAB1."
            Exit Sub
        End If
        Set Tab1ResultsRange = .Cells(Tab1RefRange.Row, .Columns.Count).End(xlToLeft).Offset(0, 1)
        Set Tab1RefRange = .Range(Tab1RefRange.Offset(1, 0), _
           Tab1RefRange.Offset(.Rows.Count - Tab1RefRange.Row, 0).End(xlUp))
        Tab1RefArray = Tab1RefRange.Value
    End With
    
    With Worksheets("TAB2")
        Set Tab2RefRange = FindREF(.UsedRange, "REF")
        If Tab2RefRange Is Nothing Then
            MsgBox "Can't find 'REF' column on TAB2."
            Exit Sub
        End If
        Tab2Array = .Range(Tab2RefRange.Offset(1, 0), _
           Tab2RefRange.Offset(.Rows.Count - Tab2RefRange.Row, 1).End(xlUp))
    End With
        
    For i = 1 To UBound(Tab1RefArray, 1)
        k = 0
        For j = 1 To UBound(Tab2Array, 1)
            If InStr(1, Tab1RefArray(i, 1), Tab2Array(j, 1)) > 0 Then
                If k = 0 Then
                    k = 1
                    ReDim Tab1ResultsArray(1 To 1, 1 To k)
                    Tab1ResultsArray(1, k) = Tab2Array(j, 2)
                Else
                    ResultsExists = False
                    For m = 1 To k
                        If Tab1ResultsArray(1, m) = Tab2Array(j, 2) Then
                            ResultsExists = True
                            Exit For
                        End If
                    Next m
                    If Not ResultsExists Then
                        k = k + 1
                        ReDim Preserve Tab1ResultsArray(1 To 1, 1 To k)
                        Tab1ResultsArray(1, k) = Tab2Array(j, 2)
                    End If
                End If
            End If
        Next j
        If k > 0 Then
            If k > iResults Then iResults = k
            Worksheets("TAB1").Cells(Tab1RefRange.Cells(i, 1).Row, Tab1ResultsRange.Column).Resize(1, k).Value = Tab1ResultsArray
        End If
    Next i
    If iResults > 0 Then
        Tab1ResultsRange.Resize(1, iResults).Value = "Results"
    End If
End Sub

Function FindREF(SearchRange As Range, Text As String) As Range
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    With SearchRange
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = SearchRange.Find(what:=Text, after:=LastCell, lookat:=xlWhole)


    If Not FoundCell Is Nothing Then
        Set FindREF = FoundCell
    End If
End Function

 

[kparadise]

Great!