将格式化文本从excel复制到word

我有一个excel表格，有两列字符串。我使用ms word跟踪这两列的更改，并将结果复制回第三列。然后我将第三列复制到一个新的word文档中

我想将单元格C3中Excel的格式转换为word。

这就是我现在得到的。请注意完整的删除。

为什么它能工作两次，但在第三种情况下不能工作

我想问题的根源在于我删除了word to excel步骤中的CR/Linefeed，并破坏了strike through格式的边界。我的目标是将每个字符串放在一个单词的段落中。如果我不删除CR/换行符，我会得到四个段落。 背景：在最终的应用程序中，字符串将是文本的段落

excel vba宏（excel 2010）的源代码： 技术备注：您可能需要在excel vba中激活ms word对象。（Microsoft Word 14.0对象库） 宏假定范围（A1:B3）中有一个字符串： 比如说

a string a string, too a string a new string a string there is no try

---

我认为你需要给我们展示一个例子，说明你得到了什么，以及你期望得到什么。我运行代码时看到的结果与我从问题描述中了解到的不匹配。我也不认为结果是你想要的。。。我也不确定我是否完全遵循了发生的事情的逻辑。但从我看到的情况来看，我怀疑您需要单独复制/粘贴每一行条目，而不是作为一个块，并希望Excel将它们粘贴到正确的单元格中。我还要问自己，将这些信息存储在Excel中是否有意义……第二次扫描给了我一个完全不同的结果。保留了所有格式，但第3行的信息不完整。这是因为Word是如何比较两个完全不同的字符串的：它将每个字符串放在自己的段落中，而不是“合并”两个相似的字符串。在查找/替换期间，它们之间的段落不会被删除（顺便说一句，您应该使用^013作为搜索词而不是vbCrLf-Word不会将其用于段落标记，只有vbCr）-这可能与“保护”一词有关轨迹更改标记。如果我添加代码以删除正在比较的两个文档中的最后一段标记，则两组标记在比较文档中位于同一行，但没有分隔。格式保留，但是：doc（j）。parations.Last.Range.Select:wordapp.Selection.Delete我尝试了你的行，但没有达到预期效果。一个改进的问题是“如何在保留格式的同时删除它们之间的段落？”

Option Explicit

Dim numberOfBlocks As Long


Sub main()

    Dim i As Long
    Dim tSht As Worksheet
    Dim wordapp As Word.Application
    Dim wdoc As Word.Document

    Set tSht = ThisWorkbook.ActiveSheet
    numberOfBlocks = 3
    Application.ScreenUpdating = False
    Set wordapp = CreateObject("Word.Application")

    For i = 1 To numberOfBlocks
       Call trackChanges(i, wordapp, tSht)
    Next i

    Set wdoc = wordapp.Documents.Add
    Call copyChanges(tSht, wdoc)

End Sub

Sub trackChanges(i As Long, wordapp As Word.Application, tSht As Worksheet)

    Dim diffDoc As Word.Document
    Dim textString() As Variant
    Dim j As Long

    ReDim doc(2)
    ReDim textString(2)

    Set textString(1) = tSht.Range("A" & i)
    Set textString(2) = tSht.Range("B" & i)

    For j = 1 To 2
        With wordapp
                Set doc(j) = .Documents.Add
                textString(j).Copy
                doc(j).Paragraphs(1).Range.PasteSpecial
        End With
    Next j

    wordapp.CompareDocuments OriginalDocument:=doc(1), RevisedDocument:=doc(2), _
        Destination:=wdCompareDestinationNew, Granularity:=wdGranularityCharLevel

    For j = 1 To 2
        doc(j).Close SaveChanges:=False
    Next j

    Set diffDoc = wordapp.ActiveDocument
    wordapp.Visible = True

    'if the answer has two paragraphs, get both in one paragraph
    With diffDoc.Content.Find
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = False
                    .MatchAllWordForms = False
                   .MatchSoundsLike = False
                    .MatchWildcards = True
                    .Text = vbCrLf
                    .Replacement.Text = " "
                    .Execute Replace:=wdReplaceAll
     End With

    diffDoc.Range.Copy
    tSht.Range("C" & i).Select
    tSht.PasteSpecial Format:="HTML"

    With tSht.Range("C" & i)
        .WrapText = True
        .Font.Name = textString(2).Font.Name
        .Font.Bold = textString(2).Font.Bold
        .Font.Size = textString(2).Font.Size
        .Rows.AutoFit
        .Interior.Color = textString(2).Interior.Color
    End With
    diffDoc.Close SaveChanges:=False
    Application.CutCopyMode = False

    Set diffDoc = Nothing

End Sub


Sub copyChanges(tSht As Worksheet, wdoc As Word.Document)

   tSht.Range("C1:C" & numberOfBlocks).Copy
   wdoc.Range(wdoc.Range.End - 1, wdoc.Range.End).PasteSpecial Placement:=wdInLine, DataType:=wdPasteHTML
   wdoc.Tables(1).ConvertToText Separator:=wdSeparateByParagraphs

End Sub