insert multi-line Text also with tabs from Word into one Excel Cell

Question

Problem: I have some formatted text from word that I want to insert in ONE Cell of Excel. I don't find a way to get this done: With PasteSpecial xlPasteAll I get a kind of picture into the cell screen: xlPasteAll. With PasteSpecial xlPasteValues I get the Text in many Cells and the red color of some text is missing screen: xlPasteValues with xlPasteFormats.

Do you have any ideas to solve this problem. I searched now many hours in the forum but was not successful.

---

Set oRng = WordDoc.Range
Set myrange = oRng.Duplicate

    With myrange.Find
        .Execute FindText:="Start*Next", matchwildcards:=True
                savedTxt = Mid(myrange.Text, 6, Len(myrange.Text) - 9)
    End With

            myrange.Copy
            Debug.Print myrange

    With ActiveSheet.Range("E5")
                '.PasteSpecial xlPasteAll
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats

    End With

---

improvements according help, but still paste over a number of cells

---

Dim FileToOpen
Dim WordApp As Object
ChDrive "C:\"
DownloadsPath = Environ$("USERPROFILE") & "\Downloads"
ChDir DownloadsPath

FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="Word Files *.docx (*.docx),")
If FileToOpen = False Then
    MsgBox "No file specified.", vbExclamation, "Error"
    Exit Sub
Else
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True
    On Error Resume Next
    'WordApp.Documents.Open Filename:=FileToOpen
    Set WordDoc = WordApp.Documents.Open(FileToOpen)
End If

Set oRng = WordDoc.Range
Set myrange = oRng.Duplicate


'set start position to "project description" -> jump over table of contents
' orng.Find.Execute(findtext:="Project Description", matchwildcards:=True) 'returns True
StartDescription = InStr(1, oRng, "Project description", vbTextCompare)

colPrj = 1
nrow = 1

Set oRng = WordDoc.Range
Set oRng = wdApp.Application.ActiveDocument.Range(Start:=StartDescription, End:=0)

Dim nexti As Long
Dim pos As Long

Dim fend As Boolean
fend = False

Do While Not IsEmpty(Cells(nrow, colPrj).Value)
    prjName = Cells(nrow, colPrj)
    Position = InStr(1, myrange, prjName, vbTextCompare)
    'find Position: start of the Project Name
    If Position > 0 Then
        'next steps area is until next Project Name
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = False
            .Forward = True
            .Wrap = wdFindStop
            .MatchWildcards = True
            .Text = "Next Steps*Project Name: "
            .Execute
            If .found = True Then
                .Start = .Start + 11
                .End = .End - 14
                With .Duplicate.Find
                  .Wrap = wdFindStop
                  .MatchWildcards = True
                  .Text = "[^13^l]"
                  .Replacement.Text = "¶"
                  .Execute Replace:=wdReplaceAll
                  .Text = "^t"
                  .Replacement.Text = "§"
                  .Execute Replace:=wdReplaceAll
                End With
                oRng.Copy
                With ActiveSheet
                  .Paste Destination:=.Range("C" & nrow)
                  With .Range("C" & nrow)
                    For i = 1 To Len(.Text)
                      With .Characters(i, 1)
                        If .Text = "¶" Then .Text = Chr(10)
                        If .Text = "§" Then .Text = vbTab
                      End With
                    Next
                  End With
                End With
            End If
        End With
    End If
nrow = nrow + 1
Loop
    
WordApp.Quit
Set WordApp = Nothing
Set WordDoc = Nothing
             

---

I get better results with direct assignment than with .PasteSpecial, but then I loose all formats. Range("E5") = myrange

Answer 1

You haven't provided enough code to provide the context as to how you're accessing the Word document. That said, you could use code like:

Sub FormatData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim WkSht As Worksheet, i As Long
Set WkSht = ActiveSheet
With wdApp
  .Visible = True
  Set wdDoc = .Documents.Add
  With wdDoc
    With .Range
      WkSht.Range("E5").Copy
      .Paste
      'do your formatting here, then
      
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = "Start*Next"
        .Execute
      End With
      If .Find.Found = True Then
        .Start = .Start + 5
        .End = .End - 4
        With .Duplicate.Find
          .Wrap = wdFindStop
          .MatchWildcards = True
          .Text = "[^13^l]"
          .Replacement.Text = "¶"
          .Execute Replace:=wdReplaceAll
          .Text = "^t"
          .Replacement.Text = "§"
          .Execute Replace:=wdReplaceAll
        End With
        .Copy
        With WkSht
          .Paste Destination:=.Range("E5")
          With .Range("E5")
            For i = 1 To Len(.Text)
              With .Characters(i, 1)
                If .Text = "¶" Then .Text = Chr(10)
                If .Text = "§" Then .Text = vbTab
              End With
            Next
          End With
        End With
      End If
    End With
    .Close SaveChanges:=False
  End With
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Note: If your text is more than 255 characters long, you will need to use a different approach (e.g. outputting to a new workbook the raw content from Word to a new workbook, then merging cells there before copying the merged content back into your own workbook).