Concatenate Unique Strings With Criteria And Ignore Blank

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Hello and thank you for any attention my post may receive.

I am attempting to concatenate unique strings with criteria and ignore blank cells, which the code below (courtesy of VBasic2008) does nicely. Its purpose is to retrieve unique ((comma) separated) (ResultSeparator) data, determined by a criteria (Criteria) in a specified column (CriteriaRange), from another specified column (SourceRange), possibly containing (comma) separated (StringSeparator) strings. The formula used in the wb is =CritJoe(SourceRange, CriteriaRange, Criteria), which in my case is
Excel Formula:
=CritJoe(B:E,F:F,F1)
.

However, this code only looks at rows in a single column (e.g. col B), and I would like to resize to rows in 4 contiguous columns (e.g. col B to E).

What changes do I need to make to the below code to achieve my desired result?

If a simple workbook is needed then

VBA Code:
' Written by VBasic2008

Function CritJoe(SourceRange As Range, CriteriaRange As Range, _
  Criteria As String, Optional StringSeparator As String = "", _
  Optional ResultSeparator As String = ", ") As String

    Dim vntS            ' Source Array (1-based, 2-dimensional)
    Dim vntC            ' Criteria Array (1-based, 2-dimensional)
    Dim vntSS           ' Source String Array (0-based, 1-dimensional)
    Dim vntR            ' Resulting Array (0-based, 1-dimensional)
    Dim i As Long       ' Source & Criteria Array Elements Counter
    Dim j As Long       ' Resulting Array Elements Counter
    Dim k As Long       ' Source String Array Elements Counter
    Dim UB As Long      ' Current Resulting Array's Upper Bound
    Dim strS As String  ' Current Source String
    Dim strR As String  ' Resulting String

    ' Check if SourceRange and CriteriaRange have the same number of rows and
    ' have the same first row number.
    If SourceRange.Rows.Count <> CriteriaRange.Rows.Count Or _
      SourceRange.Rows(1).Row <> CriteriaRange.Rows(1).Row Then GoTo RowsError
    ' Note:  The relevant data has to be in the first column of each range if (accidentally) more columns have been selected.
   
    ' Copy first column of the Ranges to Arrays.
    vntS = SourceRange.Cells(1).Resize(SourceRange.Rows.Count)
    vntC = CriteriaRange.Cells(1).Resize(CriteriaRange.Rows.Count)
    ' Write relevant data to Resulting Array.
    For i = 1 To UBound(vntS)
        If vntC(i, 1) = Criteria Then
            strS = vntS(i, 1)
            If StringSeparator <> "" Then
                ' Write Resulting String to Resulting Array using
                ' StringSeparator.
                GoSub SplitString
            Else
                ' Write Resulting String to Resulting Array without using StringSeparator.
                GoSub StringToArray
            End If
        End If
    Next
    ' Write relevant data from Resulting Array to Resulting String.
    If IsArray(vntR) Then
        strR = vntR(0)
        If UBound(vntR) > 0 Then
            For j = 1 To UBound(vntR)
                strR = strR & ResultSeparator & vntR(j)
            Next
        End If
    End If
    CritJoe = strR
Exit Function

' Write Resulting String to Resulting Array using StringSeparator.
SplitString:
    vntSS = Split(strS, StringSeparator)
    For k = 0 To UBound(vntSS)
        strS = Trim(vntSS(k))
        GoSub StringToArray
    Next
    Return
' Write Resulting String to Resulting Array.
StringToArray:
    If IsArray(vntR) Then
        ' Handle all except the first element in Resulting Array.
        UB = UBound(vntR)
        For j = 0 To UB
            If vntR(j) = strS Then Exit For
        Next
        If j = UB + 1 Then
            ReDim Preserve vntR(j): vntR(j) = strS
        End If
    Else
        ' Handle only first element in Resulting Array.
        ReDim vntR(0): vntR(0) = strS
    End If
    Return

RowsError:
    CritJoe = "Rows Error!"
End Function
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,400
Office Version
  1. 365
Platform
  1. Windows
Then even the UDF may be a bit sluggish on large data? If so and the results do not have to be dynamic then you might want to test something like this as well.

VBA Code:
Sub Unique_By_Date()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, fr As Long
  Dim dte As Date
  
  a = Range("B3", Range("F" & Rows.Count).End(xlUp).Offset(1)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  Set d = CreateObject("Scripting.Dictionary")
  i = 1
  Do
      fr = i
      dte = a(i, 5)
      Do While a(i, 5) = dte
        For j = 1 To 4
          If Len(a(i, j)) > 0 Then d(a(i, j)) = 1
        Next j
        i = i + 1
      Loop
      b(fr, 1) = Join(d.keys, ", ")
      d.RemoveAll
  Loop Until i = UBound(a)
  Range("G3").Resize(UBound(b)).Value = b
End Sub
 

Some videos you may like

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Then even the UDF may be a bit sluggish on large data? If so and the results do not have to be dynamic then you might want to test something like this as well.

VBA Code:
Sub Unique_By_Date()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, fr As Long
  Dim dte As Date
 
  a = Range("B3", Range("F" & Rows.Count).End(xlUp).Offset(1)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  Set d = CreateObject("Scripting.Dictionary")
  i = 1
  Do
      fr = i
      dte = a(i, 5)
      Do While a(i, 5) = dte
        For j = 1 To 4
          If Len(a(i, j)) > 0 Then d(a(i, j)) = 1
        Next j
        i = i + 1
      Loop
      b(fr, 1) = Join(d.keys, ", ")
      d.RemoveAll
  Loop Until i = UBound(a)
  Range("G3").Resize(UBound(b)).Value = b
End Sub
Oh wow thank you Peter. I truly appreciate your time and experience.

I will test this out and let you know how it goes regarding speed improvement.
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,097
Office Version
  1. 365
Platform
  1. Windows
Just because it was a good bit of fun, I wanted to share my stab at the formula solution as well.

Excel Formula:
=IF(COUNTIF($E$3:E3,E3)=1,TEXTJOIN(", ",1,UNIQUE(LET(
tbl,$A3:INDEX($A3:$D$22,COUNTIF($E$3:$E$22,E3),4),
col,COLUMNS(tbl),
seq,SEQUENCE(,ROWS(tbl)*col,0),
INDEX(tbl,INT(seq/(col))+1,MOD(seq,col)+1)),1)),
"")
 
Last edited:

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,097
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You could also use Power Query.

Book One.xlsb
ABCDEFGH
1OP 1OP 2OP 3OP 4datedateCount
2KateDaveJennyDan1/31/20211/31/2021Kate, Dave, Jenny, Dan, Bill, Sue, Declan, John
3JennyBillSue1/31/20212/1/2021John, Sue, Jenny, Kate, Dave, Bill, Dan, Declan
4DeclanBillKateJohn1/31/20212/2/2021Jenny, Dave, Bill, Dan, Sue, Kate, John
5JohnSueJenny2/1/20212/3/2021John, Jenny, Kate, Dave, Bill, Dan
6KateDaveBillDan2/1/20212/4/2021Jenny, John, Bill, Declan, Kate, Sue, Dave, Dan
7DanJennyBill2/1/20212/5/2021Declan, Bill, Kate, John, Jenny
8DeclanBillKateJenny2/1/2021
9JohnBillSue2/1/2021
10JennyDaveBillDan2/2/2021
11DanJennySue2/2/2021
12JennyBillKateJohn2/2/2021
13JohnJenny2/3/2021
14KateDaveBillDan2/3/2021
15JennyJohnBill2/4/2021
16DeclanBillKateJohn2/4/2021
17JohnBillSue2/4/2021
18KateDaveBillDan2/4/2021
19DanJennyBill2/4/2021
20DeclanBillKateJohn2/5/2021
21JohnJenny2/5/2021
Sheet12


let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
Unpivot = Table.UnpivotOtherColumns(Source, {"date"}, "Attribute", "Value"),
Group = Table.Group(Unpivot, {"date"}, {{"Count", each _, type table [date=datetime, Attribute=text, Value=text]}}),
Extract = Table.TransformColumns(Group,{{"Count", each Text.Combine(List.Distinct(_[Value]),", ")}})
in
Extract
 

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Just because it was a good bit of fun, I wanted to share my stab at the formula solution as well.

Excel Formula:
=IF(COUNTIF($E$3:E3,E3)=1,TEXTJOIN(", ",1,UNIQUE(LET(
tbl,$A3:INDEX($A3:$D$22,COUNTIF($E$3:$E$22,E3),4),
col,COLUMNS(tbl),
seq,SEQUENCE(,ROWS(tbl)*col,0),
INDEX(tbl,INT(seq/(col))+1,MOD(seq,col)+1)),1)),
"")
Thank you Robbo.

But 'UNIQUE' and 'LET' are not available to me.
 

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You could also use Power Query.

Book One.xlsb
ABCDEFGH
1OP 1OP 2OP 3OP 4datedateCount
2KateDaveJennyDan1/31/20211/31/2021Kate, Dave, Jenny, Dan, Bill, Sue, Declan, John
3JennyBillSue1/31/20212/1/2021John, Sue, Jenny, Kate, Dave, Bill, Dan, Declan
4DeclanBillKateJohn1/31/20212/2/2021Jenny, Dave, Bill, Dan, Sue, Kate, John
5JohnSueJenny2/1/20212/3/2021John, Jenny, Kate, Dave, Bill, Dan
6KateDaveBillDan2/1/20212/4/2021Jenny, John, Bill, Declan, Kate, Sue, Dave, Dan
7DanJennyBill2/1/20212/5/2021Declan, Bill, Kate, John, Jenny
8DeclanBillKateJenny2/1/2021
9JohnBillSue2/1/2021
10JennyDaveBillDan2/2/2021
11DanJennySue2/2/2021
12JennyBillKateJohn2/2/2021
13JohnJenny2/3/2021
14KateDaveBillDan2/3/2021
15JennyJohnBill2/4/2021
16DeclanBillKateJohn2/4/2021
17JohnBillSue2/4/2021
18KateDaveBillDan2/4/2021
19DanJennyBill2/4/2021
20DeclanBillKateJohn2/5/2021
21JohnJenny2/5/2021
Sheet12


let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
Unpivot = Table.UnpivotOtherColumns(Source, {"date"}, "Attribute", "Value"),
Group = Table.Group(Unpivot, {"date"}, {{"Count", each _, type table [date=datetime, Attribute=text, Value=text]}}),
Extract = Table.TransformColumns(Group,{{"Count", each Text.Combine(List.Distinct(_[Value]),", ")}})
in
Extract
Unfortunately I don't have Power Query on my work computer. Great idea though!
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,097
Office Version
  1. 365
Platform
  1. Windows
@Peter_SSs

Is there a way using your index method to change the table below with 6 columns to the table with 2 columns?

Book1
ABCDEFGHI
1510612712510
24871381348
335484835
451241539512
541528517415
6612
7713
848
9415
1028
11712
12813
1348
1439
15517
Sheet3
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,400
Office Version
  1. 365
Platform
  1. Windows
@Peter_SSs

Is there a way using your index method to change the table below with 6 columns to the table with 2 columns?
As this is somebody else's thread and a completely different question, please start your own thread.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,589
Messages
5,625,671
Members
416,125
Latest member
NeedExcelHelp2021

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