VBA: Find & Find next function: Return multiple value in a single cell if the ID match

[apl97]

I am using find function to match ID in Report Worksheet with the ID in Data worksheet and return the data to the ID in Report Worksheet if there is a match. For unique with multiple match, the code is only returning the ID data which every is last match in the search range in Master worksheet. The code ignores the all the possible match till the last match and returns the data of last match.

Code behaving, In report worksheet, ID 313165 will only show pineapple. It will ignore Apple and kiwi.

I need help with:
1: How do I make the ID search till the end of ID Column in Data Worksheet? If the ID has multiple match then return the multiple corresponding data in single-cell with a new line in report worksheet. 2: How can we add text joint or something which will paste multiple value in same cell.
The table will help in guiding the question.


[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Data
wkst[/TD]
[TD][/TD]
[TD][/TD]
[TD]Report
wkst[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Col A[/TD]
[TD]Col B[/TD]
[TD][/TD]
[TD]Col A[/TD]
[TD]Col B[/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]Data[/TD]
[TD][/TD]
[TD]ID[/TD]
[TD]Data[/TD]
[/TR]
[TR]
[TD]313165[/TD]
[TD]Apple[/TD]
[TD][/TD]
[TD]313165[/TD]
[TD]Apple
kiwi
pineapple[/TD]
[/TR]
[TR]
[TD]164207[/TD]
[TD]Green Apple[/TD]
[TD][/TD]
[TD]164208[/TD]
[TD]Orange[/TD]
[/TR]
[TR]
[TD]164208[/TD]
[TD]Orange[/TD]
[TD][/TD]
[TD]312313[/TD]
[TD]Mango
Carrot[/TD]
[/TR]
[TR]
[TD]313165[/TD]
[TD]kiwi[/TD]
[TD][/TD]
[TD]312357[/TD]
[TD]Banana[/TD]
[/TR]
[TR]
[TD]312313 [/TD]
[TD]Mango[/TD]
[TD][/TD]
[TD]164566[/TD]
[TD]Mandarin[/TD]
[/TR]
[TR]
[TD]312357[/TD]
[TD]Banana[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]312313[/TD]
[TD]Carrot[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]164566[/TD]
[TD]Mandarin[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]313165[/TD]
[TD]Pineapple[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Sub Match_Data()

Dim wsM As Worksheet 'Master worksheet from where the data is copied
Dim wsR As Worksheet 'Report Worksheet where the data will be copied, The id to look for are store in this worksheet
Dim firstMatchRow As Long
Dim i As Long ' To start Counter
Dim LastRow As Long 'To check for last used row in ID columns in report worksheet
Dim rngMatch As Range ' To define range where the match has to be found,in master worksheet
LastRow = wsR.Range("A" & wsR.Rows.Count).End(xlUp).Row 'Check for the last row in column A in ID worksheet.

Set wsM = Worksheets("DATA") 'Worksheet where the data is coming from,it is a source worksheet
Set wsR = Worksheets("ID") 'Worksheet where the information will be paste if the condition is satisfied

For i = 2 To lngLastRow 'counter from i=2 to last used row

Set rngMatch = wsM.Range("A:A").Find( _
What:=wsR.Range("A" & i).Value, _
LookAt:=xlPart) 'Range (A:A) is where the data will be looked in Data worksheet, Find is what we are looking for from the ID and jump to next row with i counter,
'xlPart is what it will be looking at, instead of xlWhole I have used xlpart.

If Not rngMatch Is Nothing Then
firstMatchRow = rngMatch.Row

Do
wsR.Range("B" & i).Value = rngMatch.Offset(0, 1).Value
Set rngMatch = wsM.Range("A:A").FindNext(rngMatch)
Loop Until firstMatchRow = rngMatch.Row

Else
wsR.Range("C" & i).Value = "NOT FOUND"

End If
Next i
End Sub
</code>

 

[MickG]

Try this, for Data in sheet "Data" and Results in Sheet "ID" in column "B" , based on Column "A".

[COLOR="Navy"]Sub[/COLOR] MG10Aug39
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Data")
  [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Dn.Offset(, 1).Value
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Value) = .Item(Dn.Value) & ", " & Dn.Offset(, 1).Value
        MsgBox .Item(Dn.Value)
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("ID")
  [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR] Dn.Offset(, 1) = .Item(Dn.Value)
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]

Regards Mick

 

[MickG]

"Typo"
In the code above there is a line " MsgBox .Item(Dn.Value)" , Please remove it was used for testing !!!!

 

[apl97]

Thank you Mick, your code is brillant, short and easy to understand,

Even i found another way to solve it, would like to share with you.

Sub Match_Control()


Dim firstMatchRow As Long
Dim wshM As Worksheet
Dim wshR As Worksheet
Dim i As Long
Dim LastRow As Long
Dim rngMatch As Range ' To define range where the match has to be found
Dim xreturn As String 'To store the string for single cell
LastRow = wshR.Range("A" & wshR.Rows.Count).End(xlUp).Row

Set wshM = Worksheets("Sheet1")
Set wshR = Worksheets("Sheet2")

For i = 2 To LastRow
Set rngMatch = wshM.Range("A:A").Find( _
What:=wshR.Range("A" & i).Value, _
LookAt:=xlPart)

If Not rngMatch Is Nothing Then
firstMatchRow = rngMatch.Row

Do

wshR.Range("B" & i).Value = xreturn & rngMatch.Offset(0, 1).Value
Set rngMatch = wshM.Range("A:A").FindNext(rngMatch)
xreturn = wshR.Range("B" & i).Value & ", " 'it will keep on storing the value .
Loop Until firstMatchRow = rngMatch.Row

Else
wshR.Range("C" & i).Value = "NOT FOUND"

End If 'When the condition is executed and finished,
xreturn = Empty 'To clear the xreturn value for next do loop
Next i 'Increase the counter by 1 and go to search function again


End Sub

 

[Peter_SSs]

Preface: My suggestions below assume Excel through Office 365 or Excel 2019.

Do you really need a macro?

A. If so, you could try

Sub LookupIDs()
  Dim lrData As Long

  lrData = Sheets("DATA").Range("A" & Sheets("DATA").Rows.Count).End(xlUp).Row
  With Sheets("Report")
    With .Range("B2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
      .Cells(1).FormulaArray = "=TEXTJOIN(CHAR(10),TRUE,IF(DATA!A$2:A$" & lrData & "=A2,DATA!B$2:B$" & lrData & ",""""))"
      .FillDown
      .Value = .Value
      .WrapText = True
    End With
  End With
End Sub

B. If not, you could just use this formula. It is an array formula so should be entered without the {} but confirmed with Ctrl+Shift+Enter, not just Enter. If confirmed correctly, Excel will insert the {}. The formula can then be copied down. Format column B as 'Wrap Text'.

Excel Workbook
	A	B
1	ID	Data
2	313165	ApplekiwiPineapple
3	164208	Orange
4	312313	MangoCarrot
5	312357	Banana
6	164566	Mandarin
Report

 

[MickG]

You're basic code works well, but I'm unsure how you got it to run as the Set statement for "wshtR" is not initialized until after you have tried to use it in the "Lastrow" line.
Regards Mick

 

[Rick Rothstein]

Here is another macro that you can consider. It uses the same basic underlying concept as Mick's macro, but is more compact and I believe possibly a little quicker (I have no idea how it might compare speedwise to Peter's code as my version of Excel does not have the TEXTJOIN function available).

[table="width: 500"]
[tr]
	[td]Sub LookUpAndCombineIDs()
  Dim N As Long, Data As Variant
  Data = Sheets("Data").Range("A1", Sheets("Data").Cells(Rows.Count, "B").End(xlUp))
  With CreateObject("Scripting.Dictionary")
    For N = 1 To UBound(Data)
      .Item(Data(N, 1)) = .Item(Data(N, 1)) & Left(", ", 3 + 3 * (Len(.Item(Data(N, 1))) = 0)) & Data(N, 2)
    Next
    Sheets("ID").UsedRange.Clear
    Sheets("ID").Range("A1").Resize(.Count) = Application.Transpose(.Keys)
    Sheets("ID").Range("B1").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub[/td]
[/tr]
[/table]

Note: My code clears the ID sheet and then places the calculated table onto it so there is no need to put the ID's onto the ID sheet before running my code.

 

[Fluff]

Cross posted multiple sites

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

Please supply links to all other sites where you have asked this question.