Need to modify column concatenate VBA script to join selected columns only instead as well as to separate joined columns with a comma

Question

I need to take this code:

Sub ConcatColumns()

   Do While ActiveCell <> "" 


      ActiveCell.Offset(0, 1).FormulaR1C1 = _
         ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0)

      ActiveCell.Offset(1, 0).Select
   Loop

End Sub

And I need to modify it so it will not only join two columns but up to 4, with the possibility of being able to choose which columns I want to concatenate. I also need the joined text to be separated by a comma and since this is Excel, I'm wondering if there's a way I can add some formatting if one of the columns is a date?

For example, manually I have to use this formula to make sure my dates are formatted as mm/dd/yyyy when using TEXTJOIN:

=TEXTJOIN(",",TRUE,IF(I4="","",(TEXT(I4,"mm/dd/yyyy"))),IF(J4="","",(TEXT(J4,"mm/dd/yyyy"))),IF(K4="","",(TEXT(K4,"mm/dd/yyyy"))))

This is how my data looks:

Raw Data

This can go on with up to 5-10 other sets of ID's with their dates.

This is the result I need and what I'm having to do now do with =TEXTJOIN:

As you can see the dates don't come over formatted, even when I try to do it with the dropdown so I have to add some =TEXT formatting with the formula I pasted above.

Thanks in advance!

Answer 1

Here's one approach. It will concatenate selection cell contents in the order the cells/ranges were selected (luckily Excel keeps track of this when you make a multi-area selection). Result goes in the last-selected cell.

'When multiple cells in a row are selected, join the values from those cells with a comma,
'   and place the result in the last-selected cell
Sub JoinCells()
    Dim sel As Range, area As Range, c As Range, cDest As Range
    Dim addr As String, txt As String, sep As String, v

    Set sel = Selection

    'check that at least 3 cells are in the same row are selected...
    If sel.EntireRow.Cells.CountLarge > Rows(1).Count Or sel.Cells.Count < 3 Then
        MsgBox "Select at least 3 cells on the same row.", vbExclamation
        Exit Sub
    End If
    
    Do While Application.CountA(sel) > 0           'while any data in selected cells
        Set cDest = sel.Areas(sel.Areas.Count)     'last area selected
        Set cDest = cDest.Cells(cDest.Cells.Count) 'the last cell in that area is where the result goes
        addr = cDest.Address
        txt = ""    'reset result
        sep = ""    'reset separator
        For Each area In sel.Areas         'loop selected areas
            For Each c In area.Cells       'then cells within areas
                If c.Address <> addr Then  'not the "result" cell?
                    v = c.Value
                    If Len(v) > 0 Then     'any value to add?
                        txt = txt & sep & IIf(IsDate(v), Format(v, "mm/dd/yyyy"), v)
                        sep = ","          'add separator after first value
                    End If
                End If
            Next c
        Next area
        cDest.Value = txt       'populate the last selected cell
        Set sel = sel.Offset(1) 'next row down
    Loop
    
End Sub

Example: cells on row 3 were selected in the order shown while holding down Ctrl key. Make sure to select an empty cell last as the destination for the result.
Note: the macro will step down through the rows below as long as they have content, so only select cells on the first row of the data you want to work on.

Result: