Textjoin with formatting

Question

I would like to join a text from 3 cells while keeping the cells' formatting. I looked on the internet and it appears to me that the formatting cannot be preserved with textjoin function in Excel. As shown in the image below, I would like to join a text from column 1-3 with a double line between each text.

I currently use =A2&CHAR(10)&CHAR(10)&B2&CHAR(10)&CHAR(10)&C2 to get what is shown in column 4. However, I have aimed to get what is shown in column 5, instead.

Btw, I have tons of these cells to join. Any automatic ways would be much appreciated! Does anyone have thoughts on this? Thank you very much.

Answer 1

Join Cells Preserving Font Formatting

• It is assumed that the data (table) is contiguous (no empty rows or columns), it starts in cell A1 and it has one row of headers.
• Copy the complete code into a standard module, e.g. Module1.
• Adjust the values in the constants section (e.g. to get the extra line breaks ('empty rows') in the resulting cells use Const Delimiter As String = vbLf & vbLf).
• You only run the JoinCells procedure. The rest is being called.

Option Explicit

Sub JoinCells()
' Needs the 'JoinCellsPreserveFontFormatting' and 'CopyFontFormatting' procedures.
    Const ProcTitle As String = "Join Cells"
    
    Const wsName As String = "Sheet1" ' Worksheet (Tab) Name
    Const sCols As Long = 3 ' Number of Source Columns to Join
    Const dCol As String = "D" ' Destination Column
    Const Delimiter As String = vbLf
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim scrrg As Range: Set scrrg = ws.Range("A1").CurrentRegion ' has headers
    Dim srg As Range
    Set srg = scrrg.Resize(scrrg.Rows.Count - 1, sCols).Offset(1) ' no headers
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range ' Source Row Range
    Dim dCell As Range ' Destination Cell Range

    For Each srrg In srg.Rows
        Set dCell = srrg.EntireRow.Columns(dCol)
        JoinCellsPreserveFontFormatting srrg, dCell, Delimiter
    Next srrg

    Application.ScreenUpdating = True

    MsgBox "Data copied. Font formatting preserved.", vbInformation, ProcTitle

End Sub

Sub JoinCellsPreserveFontFormatting( _
        ByVal SourceRange As Range, _
        ByVal DestinationCell As Range, _
        Optional ByVal Delimiter As String = vbLf)
' Needs the 'CopyFontFormatting' procedure.
    
    Dim sCell As Range
    Dim dString As String
    
    For Each sCell In SourceRange.Cells
        dString = dString & CStr(sCell) & Delimiter
    Next sCell
    Dim delLen As Long: delLen = Len(Delimiter)
    dString = Left(dString, Len(dString) - delLen)
    
    ' Alternatively...
    ' For one row:
    'dString = Join(Application.Transpose( _
        Application.Transpose(SourceRange.Value)), Delimiter)
    ' For one column:
    'dString = Join(Application.Transpose(SourceRange.Value), Delimiter)
    
    DestinationCell.Value = dString
    
    Dim sFont As Font
    Dim s As Long
    Dim dFont As Font
    Dim d As Long
    
    For Each sCell In SourceRange.Cells
        For s = 1 To sCell.Characters.Count
            d = d + 1
            Set sFont = sCell.Characters(s, 1).Font
            Set dFont = DestinationCell.Characters(d, 1).Font
            CopyFontFormatting sFont, dFont
        Next s
        d = d + delLen
    Next sCell

End Sub

Sub CopyFontFormatting( _
    ByVal SourceFont As Font, _
    ByVal DestinationFont As Font)
    
    With DestinationFont
        .FontStyle = SourceFont.FontStyle
        .Color = SourceFont.Color
        .Underline = SourceFont.Underline
        ' Add more, or not.
        '.Size = SourceFont.Size
    End With
    
End Sub