Concatenate with style

[DocAElstein]

This slightly modified version will help get over the issue of different character formats within a cell.
In this version, only cells with formulas are subject to having that formula stored, replaced with values , and then replaced after Rick's coding

Sub ConcatWithStyles2() '  https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687
Rem 0a save any formulas, and replace with values
Dim arrFormulas(1 To 5) As Variant
Dim cnt
    For cnt = 1 To 5
        If Left(Cells.Item(1, cnt).Formula, 1) = "=" Then ' case a formula in cell
         Let arrFormulas(cnt) = Cells.Item(1, cnt).Formula
         Let Cells.Item(1, cnt).Value = Cells.Item(1, cnt).Value
        Else
        ' we don't have a formula , so we do nothing to the cell
        End If
    Next cnt
  Dim X As Long, Cell As Range, Text As String, Position As Long
  Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1"))
  Position = 1
'  Application.ScreenUpdating = False
  For Each Cell In Range("A1:F1")
    With Range("A3")
      .Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
      For X = 1 To Len(Cell.Value)
        With .Characters(Position + X - 1, 1).Font
          .Name = Cell.Characters(X, 1).Font.Name
          .Size = Cell.Characters(X, 1).Font.Size
          .Bold = Cell.Characters(X, 1).Font.Bold
          .Italic = Cell.Characters(X, 1).Font.Italic
          .Underline = Cell.Characters(X, 1).Font.Underline
          .Color = Cell.Characters(X, 1).Font.Color
          .Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
          .Subscript = Cell.Characters(X, 1).Font.Subscript
          .Superscript = Cell.Characters(X, 1).Font.Superscript
          .TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
          .FontStyle = Cell.Characters(X, 1).Font.FontStyle
        End With
      Next
    End With
    Position = Position + Len(Cell.Value) + 1
  Next
  Application.ScreenUpdating = True
Rem 0b Put the formulas back
    For cnt = 1 To 5
        If arrFormulas(cnt) <> "" Then ' case a formula was in cell
         Let Cells.Item(1, cnt).Formula = arrFormulas(cnt)
        
        Else
        ' we didnt have a formula , so we do nothing to the cell
        End If
    Next cnt

End Sub

Before:
http://i.imgur.com/gqW322Y.jpg

After running above macro:
http://i.imgur.com/792PzQY.jpg