Looking for a single text value and returning 1 or multiple text values in one cell

[cramnij]

Hello,
As suggested by Azumi this problem can probably be solved by a macro or a VBA code. Hope someone can help me with my following problem.
I want to lookup a certain text value from a worksheet (sheet 2 in example file) and find this exact text value in worksheet 1 column A. Then the result must be the corresponding text value (or values!!) from sheet 1 column C. I want the result in a single cell next to the lookup value (sheet 2).

See attached file DemoMarc3.
For example: if I lookup "Hello" the result must be: "Amsterdam". But when I Lookup "Hay" the result must be: "New York, Berlin". And when I lookup "Good Morning" the result must be: "Madrid, Madras, Amsterdam, New York". The number of empty cells between the text that I want to find in column A and the next text in column A is not a constant and will vary.
Thanks so much for all your help.
Marc

[mike7952]

This should do it

Sub abc()
 Dim i As Long, ii As Long, a
 
 With Worksheets("sheet1")
    a = .Range("a1").CurrentRegion
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(a)
        If Not IsEmpty(a(i, 1)) Then
            ii = i
            .Item(a(i, 1)) = a(i, 3)
        Else
            .Item(a(ii, 1)) = .Item(a(ii, 1)) & ", " & a(i, 3)
        End If
    Next
    With Worksheets("sheet2")
        a = .Range("a2", .Cells(Rows.Count, 1).End(xlUp).Offset(, 1))
    End With
    For i = 1 To UBound(a)
        If .exists(a(i, 1)) Then a(i, 2) = .Item(a(i, 1))
    Next
    With Worksheets("sheet2")
        .Range("a2").Resize(UBound(a), UBound(a, 2)) = a
    End With
 End With
End Sub

[cramnij]

Hi Mike,
Thank you very much for your fantastic macro! It works perfectly in the demo file. However, when I use your macro (somewhat adapted) in my real file, I get the error message: "subscript out of range".
Sheet1 in my original file is a PivotTable, is this a big problem? Hope not.
Additionally, the first text in sheet1 starts in cell A7. Therefor I adjusted your code (line 5) "a1" to "a7". This works in the demo file so I assume this is correct. I also adjusted the sheet names but I don’t know if it’s possible that sheet names contain spaces?
Sheet2 starts at cell A3. Is it necessary to make a code adjustment for that?
Finally, I'd like the result in another column (not B but M). Do not know how to modify the code for that.

Hopefully you can to help me with the final adjustments. Already many thanks in advance!
With kind regards,
Marc

[JOHN H. DAVIS]

Maybe:

Sub cramnij()
Dim x As Range
Dim y As String
Dim z As String
Dim i As Long
Dim w As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws2 = Sheets("sheet2")
Set ws = Sheets("sheet1")
i = ws.Range("A" & Rows.Count).End(3).Row
y = ""
z = ""
With ws2
    For w = 2 To ws2.Range("A" & Rows.Count).End(3).Row
Set x = ws.Columns(1).Find(.Cells(w, "A").Value, LookIn:=xlValues, Lookat:=xlWhole)
    If Not x Is Nothing Then
    ws.Activate
    Cells(x.Row, x.Column).Select
    If ActiveCell.Offset(1).Value <> "" And ActiveCell.Row <= i Then
        .Cells(w, "A").Offset(, 1).Value = ActiveCell.Offset(, 2)
    End If
    If ActiveCell.Offset(1).Value = "" Then
            y = ActiveCell.Offset(, 2).Value
            z = y & ", "
            ActiveCell.Offset(1).Select
        Do Until ActiveCell.Value <> "" Or ActiveCell.Row + 1 > i
            y = ActiveCell.Offset(, 2).Value
            z = z & y & ", "
            z = z
            ActiveCell.Offset(1).Select
        Loop
        .Cells(w, "A").Offset(, 1).Value = z
        Set x = Nothing
    End If
    End If
Next w
End With
ws2.Activate
For Each x In Range("B2:B" & Range("B" & Rows.Count).End(3).Row)
    If Right(x, 2) = ", " Then x.Value = Left(x, Len(x) - 2)
Next x
End Sub

[mike7952]

Can you upload a more realaistic workbook of how your data is laid out?

[cramnij]

Hey Mike,
As you asked, I’ve tried to make a more realistic workbook of my data. But the problem does not occur in that file. So I found that extracting data from a pivot table is not the problem. I think it’s my original pivot table that causes the problem. But why and where I can’t figure out. Here is a photo of the code and the error line a(ii,1)=<subscript out of range>. Maybe it can help you to figure out what’s wrong.

code with error line subscript out of range.JPG

Due to upload limitations it’s not possible to upload my original file (to big).
Now I found a workaround for the still existing problem in my original file, the only thing I can’t workout is how to put the data in a different column (not B but M).
Hopefully you can help me with that last hurdle.
Thanks.
Marc

[mike7952]

Something like this, If that dont work cut down your file and see if it will upload

.Range("m2").Resize(UBound(a), UBound(a, 2)) = a

[cramnij]

Hi Mike,
Almost perfect! Data ends up in the right column.
But its starts with the lookup data in column M and the result data in the next column (N).
Is it possible to put only the result data in column M? I don't need the lookup data to be returned also.
Thanks.
Marc

[mike7952]

Try this

    With Worksheets("WinnersList")
        a = .Range("a2", .Cells(Rows.Count, 1).End(xlUp))
    End With
    For i = 1 To UBound(a)
        If .exists(a(i, 1)) Then a(i, 1) = .Item(a(i, 1))
    Next
    With Worksheets("WinnersList")
        .Range("m2").Resize(UBound(a)) = a
    End With

[cramnij]

Hi Mike,
That did the trick! But…. Sorry to be such a pain…. when the lookup data is not found it will return the lookup data as a result. Is it possible to return a blank cell when the lookup is not to be found? Thanks a million!
Marc

[mike7952]

For i = 1 To UBound(a)
    If .exists(a(i, 1)) Then
        a(i, 1) = .Item(a(i, 1))
    Else
        a(i, 1) = Empty 
    End if
Next

[cramnij]

Hi Mike,
It's perfect! Your the Best!! Thanks a million!!!
Marc

[mike7952]

Your welcome