Hallo,

hmm da Du von 3 Zeilen und Inhalte einfügen sprichst, willst Du  wohl doch direkt den Text mit den Formatierungen in eine Zelle einfügen, mal ein Ansatz:

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

Gruß,