Option Explicit
Public Sub test()
Dim objCell As Range
Dim ialngIndex As Long, ialngStart As Long, ialngChar As Long
Dim lngStartCount As Long
Dim strText As String
Dim ablnBold() As Boolean
Dim alngColor() As Long
Application.ScreenUpdating = False
Call ActiveSheet.Cells(1, 1).PasteSpecial(Paste:=xlPasteAll)
For Each objCell In Selection
With objCell
If .Characters.Count > 0 Then
ialngIndex = ialngIndex + .Characters.Count
strText = strText & .Text & " "
ialngStart = 0
ReDim Preserve ablnBold(ialngIndex) As Boolean
ReDim Preserve alngColor(ialngIndex) As Long
For ialngChar = lngStartCount + 1 To ialngIndex
ialngStart = ialngStart + 1
With .Characters(Start:=ialngStart, Length:=1).Font
ablnBold(ialngChar - 1) = .Bold
alngColor(ialngChar - 1) = .Color
End With
Next
If lngStartCount = 0 Then
lngStartCount = ialngIndex + 1
Else
lngStartCount = ialngIndex
End If
End If
End With
Next
With Selection
Call .ClearContents
With .Cells(1, 1)
.WrapText = True
.Value = strText
For ialngStart = 1 To UBound(ablnBold)
With .Characters(Start:=ialngStart, Length:=1).Font
.Bold = ablnBold(ialngStart - 1)
.Color = alngColor(ialngStart - 1)
End With
Next
Call .Select
End With
End With
End Sub