循环：使用书签将基于excel列表的段落从一个文档复制到另一个文档

Question

有关更多详细信息，请参阅下面的屏幕截图。

Excel工作表

原始文档

在目标文档中我的代码输出下面

目标文档中的Macropod输出

excel文件Sheets（“ List1”），包含两列带有文本/字符串的列。 列A具有段落或表格的起始词，列B具有结束段落或表格的词。

基于A列和B列文本，宏在源文档中找到起始词和结尾词。 如果找到，则以格式设置复制源文档中的所有文本或表格，包括开始和结束的单词，并将其粘贴到具有源格式的目标文档中的书签（Text1，Text2等）上。

我要复制的段落包含文本和表格（介于两个文本之间或末尾）

如何使用书签循环来循环A和B列的文本/字符串。

在宏下面，我尝试基于源文档中的A和B列查找文本，使用格式进行复制并将其粘贴到目标文档中的书签中。

但是它选择每个循环中最后一个条目的范围（文本或表格）。 我尝试编辑以下代码，但未成功。我没有很好的编码知识。

从Macropod和我的评论中获得的答案非常好。

Sub CopyPasteParagraphsNew()
Dim wdApp As New Word.Application
Dim DocSrc As Word.Document, DocTgt As Word.Document, wdRng As Word.Range
Dim WS As Worksheet, r As Long
Dim i As Long
Dim j As Long

Dim M As Long
Dim N As Long


Set WS = Sheets("List1")
  Set MsWord = CreateObject("Word.Application")
  On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
bWeStartedWord = True
End If

With DocSrc

With MsWord
.Visible = True
.Documents.Open (ActiveWorkbook.Path & "\Source Document.doc")
.Activate

MsWord.Selection.HomeKey Unit:=wdStory
With MsWord.Selection.Find

M = Cells(Rows.Count, "A").End(xlUp).Row 'selecting last string of column A and pasting at each bookmark
For i = 1 To M
.ClearFormatting
.Wrap = wdFindStop
.MatchCase = True
.Text = Cells(i, "A").Value
.Execute
MsWord.Selection.Collapse

Next i

N = Cells(Rows.Count, "B").End(xlUp).Row 'selecting last string of column B and pasting at each bookmark
For j = 1 To N
lngStart = MsWord.Selection.End
.Text = Cells(j, "B").Value
.Execute

Next j
lngEnd = MsWord.Selection.End
MsWord.ActiveDocument.Range(lngStart, lngEnd).Copy

Set DocTgt = Documents.Open(ActiveWorkbook.Path & "\Destination Document.doc")
With DocTgt
 For t = 1 To DocTgt.Bookmarks.Count
If DocTgt.Bookmarks.Exists("Text" & t) Then

MsWord.Selection.GoTo What:=wdGoToBookmark, Name:=("Text" & t)
MsWord.Selection.PasteAndFormat wdFormatOriginalFormatting

End If
Next
End With
End With
End With
End With
End Sub

Answer 1

您的描述不清楚。也许：

Sub CopyPasteParagraphs()
Dim wdApp As New Word.Application
Dim DocSrc As Word.Document, DocTgt As Word.Document, wdRng As Word.Range
Dim WS As Worksheet, r As Long
Set WS = Sheets("List1")
With wdApp
  .Visible = True
  Set DocSrc = .Documents.Open(ActiveWorkbook.Path & "\Source Document.doc") 'SourceDocument
  Set DocTgt = Documents.Open(ActiveDocument.Path & "\Destination Document.doc")
  With DocSrc
    For r = 1 To WS.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    With .Range
      With .Find
        .Text = WS.Range("A" & r) & "*" & WS.Range("B" & r)
        .MatchWildcards = True
        .Execute
      End With
      If .Find.Found = True Then Set wdRng = .Duplicate
        With DocTgt
          If .Bookmarks.Exists("Text" & r) Then
            .Bookmarks("Text" & r).Range.FormattedText = wdRng.FormattedText
          End If
        End If
      End If
    End With
    .Close False
  End With
End With
End Sub

代替：

      If .Bookmarks.Exists("Text" & r) Then
        .Bookmarks("Text" & r).Range.FormattedText = wdRng.FormattedText
      End If

您可以使用：

      If .Bookmarks.Exists("Text" & r) Then
        wdRng.Copy
        .Bookmarks("Text" & r).Range.PasteAndFormat wdFormatOriginalFormatting
      End If