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
 

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Below is a minisheet of my workbook mentioned above.

Concat DF.xlsb
BCDEFGH
2OP 1OP 2OP 3OP 4datecurrent udf resultdesired result
3KateDaveJennyDan31/01/2021Kate, Jenny, DeclanKate, Dave, Jenny, Dan, Bill, Sue, Declan, John
4JennyBillSue31/01/2021Kate, Jenny, Declan
5DeclanBillKateJohn31/01/2021Kate, Jenny, Declan
6JohnSueJenny1/02/2021John, Kate, Dan, DeclanJohn, Sue, Jenny, Kate, Dave, Bill, Dan, Declan
7KateDaveBillDan1/02/2021John, Kate, Dan, Declan
8DanJennyBill1/02/2021John, Kate, Dan, Declan
9DeclanBillKateJenny1/02/2021John, Kate, Dan, Declan
10JohnBillSue1/02/2021John, Kate, Dan, Declan
11JennyDaveBillDan2/02/2021Jenny, DanJenny, Dave, Bill, Dan, Sue, Kate, John
12DanJennySue2/02/2021Jenny, Dan
13JennyBillKateJohn2/02/2021Jenny, Dan
14JohnJenny3/02/2021John, KateJohn, Jenny, Kate, Dave, Bill, Dan
15KateDaveBillDan3/02/2021John, Kate
16JennyJohnBill4/02/2021Jenny, Declan, John, Kate, DanJenny, John, Bill, Declan, Kate, Sue, Dave, Dan
17DeclanBillKateJohn4/02/2021Jenny, Declan, John, Kate, Dan
18JohnBillSue4/02/2021Jenny, Declan, John, Kate, Dan
19KateDaveBillDan4/02/2021Jenny, Declan, John, Kate, Dan
20DanJennyBill4/02/2021Jenny, Declan, John, Kate, Dan
21DeclanBillKateJohn5/02/2021Declan, JohnDeclan, Bill, Kate, John, Jenny
22JohnJenny5/02/2021Declan, John
23
24
25
26
27
28
29
30
Sheet1
Cell Formulas
RangeFormula
G3:G22G3=CritJoe($B$3:$E$30,$F$3:$F$30,F3)
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,373
Office Version
  1. 365
Platform
  1. Windows
My function does not have the checks that the two ranges have the same number of rows but see if this might help.

VBA Code:
Function UniqueByDate(rNames As Range, rDates As Range, dCrit As Date) As String
  Dim aNames As Variant, bDates As Variant
  Dim d As Object
  Dim i As Long, j As Long, ubNames2 As Long
  
  aNames = rNames.Value
  ubNames2 = UBound(aNames, 2)
  bDates = rDates.Value
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(bDates)
    If bDates(i, 1) = dCrit Then
      For j = 1 To ubNames2
        If Len(aNames(i, j)) > 0 Then d(aNames(i, j)) = 1
      Next j
    Else
      Exit For
    End If
  Next i
  UniqueByDate = Join(d.keys, ", ")
End Function

Nadine.xlsm
BCDEFG
2OP 1OP 2OP 3OP 4datecurrent udf result
3KateDaveJennyDan31/01/21Kate, Dave, Jenny, Dan, Bill, Sue, Declan, John
4JennyBillSue31/01/21 
5DeclanBillKateJohn31/01/21 
6JohnSueJenny1/02/21John, Sue, Jenny, Kate, Dave, Bill, Dan, Declan
7KateDaveBillDan1/02/21 
8DanJennyBill1/02/21 
9DeclanBillKateJenny1/02/21 
10JohnBillSue1/02/21 
11JennyDaveBillDan2/02/21Jenny, Dave, Bill, Dan, Sue, Kate, John
12DanJennySue2/02/21 
13JennyBillKateJohn2/02/21 
14JohnJenny3/02/21John, Jenny, Kate, Dave, Bill, Dan
15KateDaveBillDan3/02/21 
16JennyJohnBill4/02/21Jenny, John, Bill, Declan, Kate, Sue, Dave, Dan
17DeclanBillKateJohn4/02/21 
18JohnBillSue4/02/21 
19KateDaveBillDan4/02/21 
20DanJennyBill4/02/21 
21DeclanBillKateJohn5/02/21Declan, Bill, Kate, John, Jenny
22JohnJenny5/02/21 
Sheet1
Cell Formulas
RangeFormula
G3:G22G3=IF(F3=F2,"",UniqueByDate(B3:E$22,F3:F$22,F3))
 
Solution

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Thank you for your help and time Peter. I greatly appreciate your solution which gives me the result I was after.

Have a great day!
 

Peter_SSs

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

ADVERTISEMENT

Thank you for your help and time Peter. I greatly appreciate your solution which gives me the result I was after.

Have a great day!
You're welcome. Thanks for the follow-up. :)

BTW, this could be done with standard worksheet functions if you wanted to avoid vba or having to have macros enabled.
IF you have the LET function then it could be done like this. If you do not have the LET function then the formula would be considerably longer but I could post it if you were interested.
(The names could also be put in alphabetical order if desired)

Nadine.xlsm
BCDEFG
2OP 1OP 2OP 3OP 4dateresult
3KateDaveJennyDan31/01/21Kate, Dave, Jenny, Dan, Bill, Sue, Declan, John
4JennyBillSue31/01/21 
5DeclanBillKateJohn31/01/21 
6JohnSueJenny1/02/21John, Sue, Jenny, Kate, Dave, Bill, Dan, Declan
7KateDaveBillDan1/02/21 
8DanJennyBill1/02/21 
9DeclanBillKateJenny1/02/21 
10JohnBillSue1/02/21 
11JennyDaveBillDan2/02/21Jenny, Dave, Bill, Dan, Sue, Kate, John
12DanJennySue2/02/21 
13JennyBillKateJohn2/02/21 
14JohnJenny3/02/21John, Jenny, Kate, Dave, Bill, Dan
15KateDaveBillDan3/02/21 
16JennyJohnBill4/02/21Jenny, John, Bill, Declan, Kate, Sue, Dave, Dan
17DeclanBillKateJohn4/02/21 
18JohnBillSue4/02/21 
19KateDaveBillDan4/02/21 
20DanJennyBill4/02/21 
21DeclanBillKateJohn5/02/21Declan, Bill, Kate, John, Jenny
22JohnJenny5/02/21 
Sheet1 (2)
Cell Formulas
RangeFormula
G3:G22G3=IF(F3=F2,"",LET(txt,","&TEXTJOIN(",",1,FILTER(B3:E$22,F3:F$22=F3))&",",seq,SEQUENCE(LEN(txt)-LEN(SUBSTITUTE(txt,",",""))-1), TEXTJOIN(", ",1,UNIQUE(REPLACE(LEFT(txt,FIND("#",SUBSTITUTE(txt,",","#",seq+1))-1),1,FIND("#",SUBSTITUTE(txt,",","#",seq)),"")))))
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,373
Office Version
  1. 365
Platform
  1. Windows
it could be done like this.
.. or with this shorter formula (the resultant names are in different order)

Nadine.xlsm
BCDEFG
2OP 1OP 2OP 3OP 4dateresult
3KateDaveJennyDan31/01/21Kate, Jenny, Declan, Dave, Bill, Dan, Sue, John
4JennyBillSue31/01/21 
5DeclanBillKateJohn31/01/21 
6JohnSueJenny1/02/21John, Kate, Dan, Declan, Sue, Dave, Jenny, Bill
7KateDaveBillDan1/02/21 
8DanJennyBill1/02/21 
9DeclanBillKateJenny1/02/21 
10JohnBillSue1/02/21 
11JennyDaveBillDan2/02/21Jenny, Dan, Dave, Bill, Kate, Sue, John
12DanJennySue2/02/21 
13JennyBillKateJohn2/02/21 
14JohnJenny3/02/21John, Kate, Jenny, Dave, Bill, Dan
15KateDaveBillDan3/02/21 
16JennyJohnBill4/02/21Jenny, Declan, John, Kate, Dan, Bill, Dave, Sue
17DeclanBillKateJohn4/02/21 
18JohnBillSue4/02/21 
19KateDaveBillDan4/02/21 
20DanJennyBill4/02/21 
21DeclanBillKateJohn5/02/21Declan, John, Bill, Jenny, Kate
22JohnJenny5/02/21 
Sheet1 (3)
Cell Formulas
RangeFormula
G3:G22G3=IF(F3=F2,"",LET(a,FILTER(B$3:E$22,F$3:F$22=F3),r,ROWS(a),seq,SEQUENCE(r*COLUMNS(a),,0),arr,INDEX(a,MOD(seq,r)+1,seq/r+1),TEXTJOIN(", ",1,UNIQUE(FILTER(arr,arr<>0)))))
 

Nadine

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

ADVERTISEMENT

Thank you Peter.

I did consider a formula however I thought it might increase the calculation time considering it will be used in 6000+ cells. I will use your formula in a copy wb and consider which option is better suited to my project.

VBA is a good option considering the entire wb has 12 existing modules and two other udf. Also...I enjoy dabbling in VBA :)

Have a great day!
 

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
BTW I do not have the 'LET' function. As this wb will be used in a work environment it would be more suitable to use VBA as opposed to enabling the Office Insider build on an Administrator-managed system.

I am keen to join the Office Insider Program through my home PC.
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,373
Office Version
  1. 365
Platform
  1. Windows
OK, sounds like stick with the UDF then. Thanks for the explanation. (y)

Is there always exactly 4 'OP' columns?
 

Watch MrExcel Video

Forum statistics

Threads
1,127,107
Messages
5,622,782
Members
415,927
Latest member
vedasinternational

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