将带有标签的多行文本也从 Word 插入到一个 Excel 单元格中

Question

问题： 我有一些来自 word 的格式化文本，我想插入到 Excel 的一个单元格中。 我找不到完成这项工作的方法： 使用 PasteSpecial xlPasteAll 我在单元格中获得了一种图片 screen: xlPasteAll。 使用 PasteSpecial xlPasteValues 我得到了许多单元格中的文本，并且缺少某些文本的红色 screen: xlPasteValues with xlPasteFormats.

您有什么想法可以解决这个问题。我现在在论坛上搜索了几个小时，但没有成功。

---

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

---

根据帮助进行了改进，但仍然粘贴在许多单元格上

---

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
             

---

直接分配比使用 .PasteSpecial 获得更好的结果， 但后来我失去了所有格式。 范围（“E5”）=我的范围

Answer 1

您没有提供足够的代码来提供有关您如何访问 Word 文档的上下文。也就是说，您可以使用如下代码：

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

注意：如果您的文本长度超过 255 个字符，您将需要使用不同的方法（例如，将原始内容从 Word 输出到新工作簿，然后合并单元格在将合并的内容复制回您自己的工作簿之前在那里）。