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

apl97

New Member
Joined
Aug 6, 2019
Messages
2
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.


Data
wkst
Report
wkst
Col ACol BCol ACol B
IDDataIDData
313165Apple313165Apple
kiwi
pineapple
164207Green Apple164208Orange
164208Orange312313Mango
Carrot
313165kiwi312357Banana
312313 Mango164566Mandarin
312357Banana
312313Carrot
164566Mandarin
313165Pineapple

<tbody>
</tbody>



<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>
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this, for Data in sheet "Data" and Results in Sheet "ID" in column "B" , based on Column "A".
Code:
[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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
"Typo"
In the code above there is a line " MsgBox .Item(Dn.Value)" , Please remove it was used for testing !!!!
 

apl97

New Member
Joined
Aug 6, 2019
Messages
2
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,398
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Do you really need a macro?

A. If so, you could try
Code:
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
AB
1IDData
2313165ApplekiwiPineapple
3164208Orange
4312313MangoCarrot
5312357Banana
6164566Mandarin
Report
 
Last edited:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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

MrExcel MVP
Joined
Apr 18, 2011
Messages
37,139
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
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).
Code:
[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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,878
Office Version
  1. 365
Platform
  1. Windows
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.
 

Forum statistics

Threads
1,136,260
Messages
5,674,682
Members
419,520
Latest member
Jennifer4Dillon

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top