Цикл: копирование абзаца на основе списка Excel из одного документа в другой с использованием закладки - PullRequest
Новая
       69

Цикл: копирование абзаца на основе списка Excel из одного документа в другой с использованием закладки

0 голосов
/ 22 мая 2019

Для получения более подробной информации см. Снимок экрана ниже.

Лист Excel

Excel sheet

Исходный документ

Source Document

Ниже вывода моего кода в документе назначения Below my code output in Destination Document

Вывод макропода в документе назначения

Macropod output in Destination Document

Лист файлов Excel («Список1»), содержащий два столбца с текстом / строкой.Столбец 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

1 Ответ

1 голос
/ 23 мая 2019

Ваше описание неясно.Возможно: 

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
...