CODEWITHSUNDEEP
excelvbams-word
strahanstoothgap
strahanstoothgap

Reputation: 163

Loop through Excel rows, key in on value in Word, paste Excel string

I am trying to loop through Excel rows, where column A holds text that I want to find in Word. Column B holds what I want to paste in Word after the end of the paragraph in which the text is found.

When working in Word VBA, the find text is working and moving to the end of the paragraph works. But when I move to Excel VBA, the find method doesn't seem to be doing anything. 

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

Upvotes: 0

Views: 204

Answers (1)

xidgel
xidgel

Reputation: 3145

I think this code does what you're after. I made a number of small changes to the code in the original post, some important, some not so much. Hopefully the comments help explain why I did what I did:

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

Hope that helps

Upvotes: 0

Related Questions