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.

CodePudding user response：

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