CODEWITHSUNDEEP
excelvbams-word
Dan
Dan

Reputation: 95

VBA copy text from two word documents based on excel condition

I am trying to create a sub from excel that will open two existing word files one with standard text and another blank. These word documents and the excel workbook have the same string values as the bookmarks. If the corresponding cells adjacent to the excel bookmark are not blank I want to copy the standard text across to the other document. It just keeps crashing my excel, any ideas?

Sub BoQtoWord()
'Proof of concept to copy text from standard word doc to new word doc at same bookmark if condition met in excel workbook

Dim StdDoc As Word.Document
Dim NewDoc As Word.Document
Dim StdSpec As String
Dim NewSpec As String
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ActiveSheet
Dim iRow As Integer
iRow = 6
Dim Bkm As String


'Get first doc
StdSpec = Application.GetOpenFilename(Title:="Please choose standard spec to open", _
FileFilter:="Word Files *.doc* (*.doc*),")
Set StdDoc = Documents.Open(StdSpec)

'Get second doc
NewSpec = Application.GetOpenFilename(Title:="Please choose new spec to open", _
FileFilter:="Word Files *.doc* (*.doc*),")
Set NewDoc = Documents.Open(NewSpec)


'Loop through worksheet in workbook and copy data from standard doc to new doc at same bookmark if values populated in column 4 and 7.

For Each ws In wb.Worksheets

    For iRow = 6 To 200
        Bkm = Cells(iRow, 9).Value
            If Cells(iRow, 9) <> "" And Cells(iRow, 4) <> "" Then

            Documents(StdDoc).Activate
            Selection.GoTo What:=wdGoToBookmark, Name:="Bkm"
            Selection.Copy

            Documents(NewDoc).Activate
            Selection.GoTo What:=wdGoToBookmark, Name:="Bkm"
            Selection.Paste

        End If
        iRow = iRow + 1

    Next iRow

Next



End Sub

Upvotes: 0

Views: 185

Answers (1)

Tim Williams
Tim Williams

Reputation: 166126

Untested:

Sub BoQtoWord()

    Dim wdApp As Word.Application
    Dim StdDoc As Word.Document
    Dim NewDoc As Word.Document
    Dim StdSpec As String
    Dim NewSpec As String
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim iRow As Integer
    iRow = 6
    Dim Bkm As String

    Set wdApp = New Word.Application '<<<  create a Word application object

    wdApp.Visible = True '<<<< EDIT - added so you can see any errors 

    StdSpec = Application.GetOpenFilename(Title:="Please choose standard spec to open", _
                                          FileFilter:="Word Files *.doc* (*.doc*),")

    Set StdDoc = wdApp.Documents.Open(StdSpec) '<< you need to call Documents.Open on the word app..

    NewSpec = Application.GetOpenFilename(Title:="Please choose new spec to open", _
                                          FileFilter:="Word Files *.doc* (*.doc*),")

    Set NewDoc = wdApp.Documents.Open(NewSpec)

    For Each ws In wb.Worksheets
        For iRow = 6 To 200
            'Need to use ws here to make sure you're
            '  referencing the correct sheet...
            Bkm = ws.Cells(iRow, 9).Value
            If ws.Cells(iRow, 9) <> "" And ws.Cells(iRow, 4) <> "" Then
                'no need for any selection to copy/paste
                StdDoc.Bookmarks(Bkm).Range.Copy
                NewDoc.Bookmarks(Bkm).Range.Paste
            End If
        Next iRow
    Next

End Sub

Upvotes: 2

Related Questions