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.
Edit 2020-05-27: Adding ability to result in unique list, by adding flag (UniqueList = 1), default is not unique.
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 UniqueList = 0, _
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 + 1
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
If UniqueList <> 0 Then
' Make it unique too
For Each Itt In Split(Rett, Sepa)
If UCase(Itt) = UCase(Item2) Then
Found1 = 1
Exit For
End If
Next
End If
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 UniqueList = 0, Optional Wb = "This", Optional Shee = "Active", Optional Sepa = "||", Optional StartFromRow = 1

Views 234 Downloads 58

VBA-Excel Texts + Strings
ANmarAmdeen
725
Attachments
Revisions

v4.0