• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

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

Aditya.pal.97

New Member
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 ID with multiple match, the code is only returning the ID data which every is last match in the search range in Data 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 WorksheetReport worksheet
Col ACol BCol ACol B
IDDataIDData
313165Apple313165Apple
kiwi
pineapple
164207Green Apple164208Orange
164208Orange312313Mango
Carrot
313165kiwi312357Banana
312313Mango164566Mandarin
312357Banana
312313Carrot
164566Mandarin
313165Pineapple




Code:
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 AsLong' To start Counter
Dim LastRow AsLong'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 =2To 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
 
Hi Everyone,
I asked the question and later I found the solution so I would like to post my code which is actually working as desired.
Code:
Sub Match_Control()

    Dim firstMatchRow As Long
    Dim wshM As Worksheet
    Dim wshR As Worksheet
    Dim i As Long ' To start Counter
    Dim LastRow As Long 'To check for last used row in ID columns
    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
    
    Set wshM = Worksheets("Sheet1") 'Worksheet where the data is coming from,it is a source worksheet
    Set wshR = Worksheets("Sheet2") 'Worksheet where the information will be paste if the condition is satisfied
    LastRow = wshR.Range("A" & wshR.Rows.Count).End(xlUp).Row 'Check for the last row in column A in SRDS ID worksheet. It will check from bottom and which is the first used row
    For i = 2 To LastRow 'counter from i=2 to last used row
    Set rngMatch = wshM.Range("A:A").Find( _
            What:=wshR.Range("A" & i).Value, _
            LookAt:=xlPart) 'Range (J:J) is where the data will be looked in SRDS to Control worksheet, Find is what we are looking for from the SRDS ID and jump to next row with IngRow 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
        
        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 & ", "
      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
 
Hi !​
According to forum rules, better than a result table as text is to attach a workbook according to your need,​
that's easier for any helper to post an accurate sample …​
Another way demonstration :​
Code:
Sub Demo1()
    Dim V, R&
#If Mac Then
    MsgBox "Sorry as it works only under Windows try Demo2 instead.", vbExclamation, " Demo1"
#Else
    With Sheet1.UsedRange
        If .Columns.Count = 1 Or .Rows.Count = 1 Then Beep: Exit Sub
        V = .Value2
    End With
    With CreateObject("Scripting.Dictionary")
        For R = 1 To UBound(V)
            If .Exists(V(R, 1)) Then .Item(V(R, 1)) = .Item(V(R, 1)) & vbLf & V(R, 2) Else .Add V(R, 1), V(R, 2)
        Next
            Sheet2.UsedRange.Clear
            Sheet2.[A1:B1].Resize(.Count).Value2 = Application.Transpose(Array(.Keys, .Items))
           .RemoveAll
    End With
            Sheet2.UsedRange.VerticalAlignSheet2nt = xlCenter
#End If
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 
As previous demonstration works only under Windows and​
as it can be achieved just using Excel basics (here an advanced filter & MATCH worksheet function)
so this is a demonstration for Mac & Windows :​
Code:
Sub Demo2()
         Dim V, Rg As Range, W
         Sheet2.UsedRange.Clear
    With Sheet1.UsedRange.Columns(1)
           .AdvancedFilter xlFilterCopy, , Sheet2.[A1], True
            V = Sheet2.UsedRange.Offset(, 1).Value2
        For Each Rg In .Cells
            W = Application.Match(Rg.Value2, Sheet2.UsedRange, 0)
            V(W, 1) = IIf(V(W, 1) > "", V(W, 1) & vbLf, "") & Rg(1, 2).Value2
        Next
    End With
        Sheet2.UsedRange.Offset(, 1).Value2 = V
        Sheet2.UsedRange.VerticalAlignment = xlCenter
End Sub
You may Like it !​
 
I am using find function to match ID
So for those wanting to use find function Range.Find method (whatever for Mac or Windows)
(as post #2 code does not work on my side with different Excel versions !) another demonstration :​
Code:
Sub DemoUsingFindMethod()
         Dim Rw As Range, Rf As Range, R&
         Application.ScreenUpdating = False
         Sheet2.UsedRange.Clear
    For Each Rw In Sheet1.[A1].CurrentRegion.Rows
         Set Rf = Sheet2.UsedRange.Columns(1).Find(Rw.Cells(1).Value2, , xlValues, xlWhole)
          If Rf Is Nothing Then
             R = R + 1
             Rw.Copy Sheet2.Cells(R, 1)
          Else
             Rf(1, 2).Value2 = Rf(1, 2).Value2 & vbLf & Rw.Cells(2).Value2
          End If
    Next
         Set Rf = Nothing
         Sheet2.UsedRange.VerticalAlignment = xlCenter
         Application.ScreenUpdating = True
End Sub
You should Like it !​
 
Back
Top