Sub ConcatWithStyles()
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
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
End Sub
Solved by G. L. in 20 mins