CreateList_Matching

Creates list of items found in rows, where these rows match a value in another column.
Think of it as multiple VLOOKUPs, but concatenated and return output as list with custom separator.
Pass workbook, sheet name, and separator as usual with most of my functions.
The return is not a Unique list, we can add that (note commented lines) in future versions.


Public

Tested

My Own Work
Function CreateList_Matching(ColumnNam, MatchingColumn, MatchingValue, _
Optional Wb = "This", Optional Shee = "Active", Optional Sepa = "||", Optional StartFromRow = 1)
' Create list of items from ColumnNam, when MatchingColumn = MatchingValue
If Wb = "This" Then Wb = ThisWorkbook.Name
If Wb = "Active" Then Wb = ActiveWorkbook.Name
If Shee = "Active" Then Shee = Workbooks(Wb).Worksheets(1).Name
Rett = ""
CreateList_Matching = Rett
If ColumnNam = "" Then ColumnNam = "B"
If MatchingColumn = "" Then ColumnNam = "A"
If MatchingValue = "" Then Exit Function
DoEvents
I1 = StartFromRow
I2 = WorksheetFunction.CountA(Workbooks(Wb).Worksheets(Shee).Range(MatchingColumn & 1).EntireColumn)
Rett = ""
Do Until I1 > I2
Item1 = Workbooks(Wb).Worksheets(Shee).Range(MatchingColumn & I1).Value
Item2 = Workbooks(Wb).Worksheets(Shee).Range(ColumnNam & I1).Value
If IsError(Item1) Then Item1 = CStr(Item1)
If IsError(Item2) Then Item2 = CStr(Item2)
If Item1 = "" Or Item2 = "" Then GoTo NextI1
If UCase(Item1) = UCase(MatchingValue) Then
Found1 = 0
' For Each Itt In Split(Rett, Sepa)
' If UCase(Itt) = UCase(Item2) Then
' Found1 = 1
' Exit For
' End If
' Next
If Found1 = 0 Then
If Rett > "" Then Rett = Rett & Sepa
Rett = Rett & Item2
End If
End If
NextI1:
I1 = I1 + 1
DoEvents
Loop
CreateList_Matching = Rett
End Function

ColumnNam, MatchingColumn, MatchingValue, Optional Wb = "This", Optional Shee = "Active", Optional Sepa = "||", Optional StartFromRow = 1

Views 58 Downloads 15

VBA-Excel Texts + Strings
ANmarAmdeen
718
Attachments
Revisions

v1.0