Avatar of SStroz
Flag for United States of America asked on

Formula or Macro needed to perform "smart concatenation with seperators"


I have an excel workbook with approx. 20 columns (CFP, CPA, etc, etc).  Most rows are "blank" but occasionally there is a "yes" in a column.

I need a formula or macro to read each column (per row), convert the "yes" to the appropriate column heading, and add a separator (, ) if there is another item in a new "concatenated column).

So, the end result would look like this:   CFP, CPA      or CFP     or    CFP, CPA, ChFc

Thanks in advance!!
Microsoft OfficeMicrosoft ExcelVBA

Avatar of undefined
Last Comment

8/22/2022 - Mon

Are there any other columns?

I'm asking because it would be useful to have a column that could be used to determine how many rows of data there are.

If there is such a thing then this should be straightforward.


Yes there are 48 other columns.  About 170,000 rows.
Ryan Chong

View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
Subodh Tiwari (Neeraj)

If you are using Excel 2016 or 365, you may use TEXTJOIN function to achieve the desired output.

Try this Array Formula which requires confirmation with Ctrl+Shift+Enter instead of Enter alone.
In AW2
=TEXTJOIN(", ",TRUE,IF(A2:AV2<>"",$A$1:$AV$1,""))

Open in new window

Confirm with Ctrl+Shift+Enter and copy it down.

Otherwise I would not suggest you to have any complex array formula or user defined function for 170,000 rows which will make your file slow.
Even in case of TextJoin after applying the formula, you can copy and paste it back as Values so that the sheet doesn't have any formula in the end to avoid unnecessary recalculation of the formulas.

Or you can try this macro to achieve the desired output.
Sub CustomConcatenate()
Dim ws As Worksheet
Dim lr As Long, lc As Long, i As Long, j As Long
Dim x, y()
Dim str As String
Application.ScreenUpdating = False
Set ws = ActiveSheet
lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lc = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
x = ws.Range("A1", ws.Cells(lr, lc)).Value
ReDim y(1 To UBound(x, 1) - 1, 1 To 1)
For i = 2 To UBound(x, 1)
    For j = 1 To UBound(x, 2)
        If x(i, j) <> "" Then
            If str = "" Then
                str = x(1, j)
                str = str & ", " & x(1, j)
            End If
        End If
    Next j
    y(i - 1, 1) = str
    str = ""
Next i
ws.Cells(2, lc + 1).Resize(lr - 1, 1).Value = y

Application.ScreenUpdating = True
MsgBox "Task completed!", vbInformation
End Sub

Open in new window

Your help has saved me hundreds of hours of internet surfing.

Thank you all for your help!

Ryan's function worked perfectly so I did not try Subodh's, but I appreciate his efforts!