将格式化文本从excel复制到单词

Question

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

单元格C3中Excel的格式化是我想转移到单词的内容。

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

为什么它会工作两次而不是第三种情况？

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

excel-vba-macro的源代码（Excel 2010）： 技术说明：您可能需要在excel-vba中激活ms-word-objects。 （Microsoft Word 14.0对象库） 宏假设，Range中有一个字符串（A1：B3）： 例如

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

结果将放入范围（C1：C3）。

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