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 416 Downloads 104

VBA-Excel Texts + Strings
ANmarAmdeen
755
Attachments
Revisions

v4.0