Прокрутите строки Excel, введите значение в Word, вставьте строку Excel

Question

Я пытаюсь выполнить цикл через строки Excel, где в столбце A содержится текст, который я хочу найти в Word. В столбце B содержится то, что я хочу вставить в Word после окончания абзаца, в котором найден текст.

При работе в Word VBA текст поиска работает и перемещается в конец абзаца. Но когда я перехожу в Excel VBA, метод find, похоже, ничего не делает.

Sub UpdateWordDoc1() 

Dim mywb As Excel.Worksheet 
Set mywb = ActiveWorkbook.ActiveSheet 
Dim wdDoc As Object, wdApp As Object 
Dim questiontext As String 
Dim oSearchRange 


On Error Resume Next 
Set wdDoc = CreateObject("C:\mydoc.docx") 
Set wdApp = wdDoc.Application 
Set oSearchRange = wdDoc.Content 

With mywb 
    For i = 2 To .Range("A6000").End(xlUp).Row 
    questiontext = .Range("A" & i).Value 
    .Range("B" & i).Copy 

    Set blabla = oSearchRange.Find.Execute.Text = questiontext 
    blabla.Select 

    Selection.movedown unit:=wdparagraph 
    Selection.moveleft unit:=wdcharacter 
    Selection.PasteAndFormat (wdFormatOriginalFormatting) 

    Next i 

End With 
'wdDoc.Close savechanges:=True 
Set wdDoc = Nothing 
Set wdApp = Nothing 
End Sub 

Answer 1

Я думаю, что этот код делает то, что вам нужно. Я сделал несколько небольших изменений в коде в исходном сообщении, некоторые важные, некоторые не так много. Надеюсь, что комментарии помогают объяснить, почему я сделал то, что я сделал:

Sub UpdateWordDoc1() 
    ' REQUIRES A REFERENCE TO: 
    ' Microsoft Word ##.# Object Library 

    Dim myws As Excel.Worksheet  ' Changed wb to ws to better abbreviate worksheet 
    Dim wdDoc As Word.Document  ' No longer a generic object 
    Dim wdApp As Word.Application ' No longer a generic object 
    Dim questiontext As String 
    Dim oSearchRange As Word.Range ' Word range is what will be searched 
    Dim i As Long     ' Loop through rows by count (Long) 

    Set myws = ActiveWorkbook.ActiveSheet 

    ' On Error Resume Next   ' Can't find bugs if they're supressed!!! 
    Set wdApp = CreateObject("Word.Application") ' Create app before opening doc 
                ' Need to explore what happens 
                ' if Word is already running 
    wdApp.Visible = True   ' Make it visible so we can watch it work 
    Set wdDoc = wdApp.Documents.Open("C:\mydoc.docx") ' Open the doc 

    With myws 
     For i = 2 To .Range("A6000").End(xlUp).Row 
      ' Word's Find function is tricky to program, because 
      ' when Find succeeds, the range is moved! (Find has many 
      ' other odd behaviors). Assuming you want to search the entire doc 
      ' for each search term, we reset the range every time through the 
      ' loop. 
      Set oSearchRange = wdDoc.Content 

      questiontext = .Range("A" & i).Value 
      .Range("B" & i).Copy 

      ' Set blabla = oSearchRange.Find.Execute.Text = questiontext 
      With oSearchRange.Find 
       ' Note that Word's Find settings are "sticky". For example, if 
       ' you were previously searching for (say) italic text before 
       ' running this Sub, Word may still search for italic, and your 
       ' search could fail. To kill such bugs, explicitly set all of 
       ' Word's Find parameters, not just .Text 
       .Text = questiontext ' This is what you're searching for 
       If .Execute Then ' Found it. 
            ' NOTE: This is only gonna make a change 
            ' at the first occurence of questiontext 
        ' When find is successful, oSearchRange will move 
        ' to the found text. But not the selection, so do Select. 
        oSearchRange.Select 

        ' Now move to where the new text is to be pasted 
        wdDoc.ActiveWindow.Selection.movedown unit:=wdparagraph 
        wdDoc.ActiveWindow.Selection.moveleft unit:=wdcharacter 

        ' While debugging, the next statement through me out of single 
        ' step mode (don't know why) but execution continued 
        ' and the remaining words in my list we're found and text 
        ' pasted in as expected. 
        wdDoc.ActiveWindow.Selection.PasteAndFormat (wdFormatOriginalFormatting) 
       End If 
      End With 
     Next i 

    End With 

    ' Clean up and close down 
    wdDoc.Close savechanges:=True 
    Set oSearchRange = Nothing 
    Set wdDoc = Nothing 
    wdApp.Quit 
    Set wdApp = Nothing 
    Set myws = Nothing 
End Sub 

Надежда, что помогает