macro or this Post:
https://excelfox.com/forum/showthrea...ll=1#post15165


Code:
Sub ConcatWithStyles() '  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 the formulas, and replace with values
Dim arrFormulas() As Variant
 Let arrFormulas() = Range("A1:F1").Formula
 Let Range("A1:F1").Value = Range("A1:F1").Value
  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
 Let Range("A1:F1").Formula = arrFormulas()
End Sub