Word Document Vba Excel - Combing two different codes

**ChrisATBAse** · 08-12-2019, 08:38 AM

Hi everyone,

I am very new to coding so I would greatly appreciate the help.

Below I have two different codes that i would like to combine or if possible run simultaneously.

One code is a find and replace that searches the entire word document for references and the other is
bookmark finder that copies specific cells in my spreadsheet and pastes it in the word document as an image.

any idea how this can be done?

Code 1:

Sub ReplaceWords()

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim worddoc As Object

Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
For Each wdRng In wdDoc.StoryRanges

With wdRng.Find
.Text = "an1"
.Replacement.Text = Range("c8")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "id1"
.Replacement.Text = Range("c5")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "rd1"
.Replacement.Text = Range("c6")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll

End With

Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing

Next wdRng
End Sub

Code 2:

Sub CopyPasteImage()

Dim ws As Worksheet, msWord As Object, itm As Range
Dim savename As String
Dim fileext As String

Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")

With msWord
.Visible = True
.Documents.Open "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
.Activate

.ActiveWindow.View = xlNormalView
Range("K2:L15").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.ActiveDocument.Bookmarks("CompanyLogo").Select

.Selection.Paste
.Selection.TypeParagraph

.ActiveWindow.View = xlNormalView
Range("N2:O6").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.ActiveDocument.Bookmarks("ClientSig").Select

.Selection.Paste
.Selection.TypeParagraph

.ActiveDocument.SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
.ActiveDocument.Close
.Quit

End With
End Sub

**Kenneth Hobs** · 08-12-2019, 09:13 AM

Welcome to the forum! Please paste code between code tags. Click the # icon on the reply toolbar to insert them. You can edit your post, select the code text and click the insert tags icon for fix your post.

Looks easy enough. The first one did not save the changed file. If you edit your code, it will save us work posting a solution.

**ChrisATBAse** · 08-12-2019, 12:39 PM

Thanks for getting back!

I made the requested changes. I did however run into problems with the code for saving the first one, could you also help with this?

Sub ReplaceWords()

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim worddoc As Object


Set wdApp = CreateObject("word.application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
For Each wdRng In wdDoc.StoryRanges


With wdRng.Find
.Text = "an1"
.Replacement.Text = Range("c8")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "id1"
.Replacement.Text = Range("c5")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "rd1"
.Replacement.Text = Range("c6")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll


End With


Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing


With worddoc


.SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"


WordApp.Quit


  End With
Next wdRng
End Sub

Sub CopyPasteImage()

Dim ws As Worksheet, msWord As Object, itm As Range
Dim savename As String
Dim fileext As String


Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")


With msWord
        .Visible = True
        .Documents.Open "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
        .Activate
   
.ActiveWindow.View = xlNormalView
    Range("K2:L15").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.ActiveDocument.Bookmarks("CompanyLogo").Select
    
.Selection.Paste
.Selection.TypeParagraph
    
.ActiveWindow.View = xlNormalView
    Range("N2:O6").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.ActiveDocument.Bookmarks("ConsulSig").Select
    
.Selection.Paste
.Selection.TypeParagraph
    
.ActiveDocument.SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
.ActiveDocument.Close
.Quit


End With
End Sub

**Kenneth Hobs** · 08-12-2019, 03:20 PM

I will finish this up later tonight. For now, see if the first routine works as needed.

Sub ReplaceWords()    Dim wdApp As Word.Application, wdDoc As Word.Document
    Dim wdRng As Word.Range, worddoc As Object
    
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Open( _
        "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
    
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "an1"
            .Replacement.Text = Range("c8")
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
            .Text = "id1"
            .Replacement.Text = Range("c5")
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
            .Text = "rd1"
            .Replacement.Text = Range("c6")
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
    worddoc.SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
    Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing
End Sub


Sub CopyPasteImage()
    Dim ws As Worksheet, msWord As Object, itm As Range
    Dim savename As String, fileext As String
    
    Set ws = ActiveSheet
    Set msWord = CreateObject("Word.Application")
    
    With msWord
        .Visible = True
        .Documents.Open "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
        .Activate
        
        .ActiveWindow.View = xlNormalView
        Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .ActiveDocument.Bookmarks("CompanyLogo").Select
        
        .Selection.Paste
        .Selection.TypeParagraph
        
        .ActiveWindow.View = xlNormalView
        Range("N2:O6").Select
        Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .ActiveDocument.Bookmarks("ConsulSig").Select
        
        .Selection.Paste
        .Selection.TypeParagraph
        
        .ActiveDocument.SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
        .ActiveDocument.Close
        .Quit
    End With
End Sub

**Artik** · 08-12-2019, 03:39 PM

Admittedly, Word is not my garden

but try it:

Sub ReplaceWordAndCopyPasteImage()

    Dim wdApp       As Word.Application
    Dim Wks         As Excel.Worksheet
    Dim wdDoc       As Word.Document

    Set Wks = ActiveSheet

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    Set wdDoc = wdApp.Documents.Open("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")

    Call ReplaceWords(wdDoc, Wks, False)
    Call CopyPasteImage(wdDoc, Wks, True)
    
    Set wdDoc = Nothing
    Set wdApp = Nothing

End Sub



Sub ReplaceWords(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    Dim wdRng       As Word.Range
    Dim varTxt      As Variant
    Dim varRngAddress As Variant
    Dim i           As Long

    varTxt = Split("an1,id1,rd1", ",")
    varRngAddress = Split("C8,C5,C6", ",")

    For Each wdRng In oDoc.StoryRanges

        With wdRng.Find
            For i = 0 To UBound(varTxt)
                .Text = varTxt(i)
                .Replacement.Text = Wks.Range(varRngAddress(i)).Value
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            Next i
        End With

    Next wdRng

    oDoc.Save

    If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
    End If

End Sub



Sub CopyPasteImage(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    With oDoc
        .Activate

        .ActiveWindow.View = wdNormalView
        Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("CompanyLogo").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph


        Wks.Range("N2:O6").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ConsulSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph

        .Save

        If boolCloseAfterExec Then
            .Close
            .Parent.Quit
        End If

    End With
End Sub

Artik

**ChrisATBAse** · 08-13-2019, 04:30 AM

Thank you for looking at this for me.

I tested it out and it actually does the job! there's just one problem.
At the end it seem to run into trouble when trying to close the word application.
An error occurs during the code listed below. I've also listed the message that pops up at the end every time i try to run the module.

Really appreciate the help.

Error message:

Run-time error'-2147417848(80010108'):

Automation error
The object invoked has disconnected from its clients.

If boolCloseAfterExec Then
            .Close
            .Parent.Quit
        End If


    End With
End Sub

**ChrisATBAse** · 08-13-2019, 04:31 AM

Thanks for checking this out for me.

I tried the code with the adjustments made but it still ran into an error when saving the document

.

snb · 08-13-2019, 06:10 AM

All you need:

Sub M_snb()
  sn=range("C5:C8")

  with Getobject("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
    activesheet.Shapes(1).CopyPicture
    .Paragraphs.First.Range.PasteSpecial
    activesheet.Shapes(2).CopyPicture
    .Paragraphs.Last.Range.PasteSpecial

    For Each it In .StoryRanges
      it.Find.execute "an1", , , , , , , , ,sn(1,4),2
      it.find.execute "id1", , , , , , , , ,sn(1,1),2
      it.find.execute  "rd1", , , , , , , , ,sn(1,2),2
    next

   .SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
   .Close 0
  end with
End Sub

**ChrisATBAse** · 08-13-2019, 07:24 AM

Gave this one a try but I keep getting errors during the find and replace function.

Sub M_snb()  sn=range("C5:C8")

  with Getobject("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
    activesheet.Shapes(1).CopyPicture
    .Paragraphs.First.Range.PasteSpecial
    activesheet.Shapes(2).CopyPicture
    .Paragraphs.Last.Range.PasteSpecial

    For Each it In .StoryRanges
      it.Find.execute "an1", , , , , , , , ,sn(1,4),2
      it.find.execute "id1", , , , , , , , ,sn(1,1),2
      it.find.execute  "rd1", , , , , , , , ,sn(1,2),2
    next

   .SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
   .Close 0
  end with End Sub

The code below works well apart from the error that occurs when trying to close the word application.

Sub ReplaceWordAndCopyPasteImage()

    Dim wdApp       As Word.Application
    Dim Wks         As Excel.Worksheet
    Dim wdDoc       As Word.Document


    Set Wks = ActiveSheet


    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True


    Set wdDoc = wdApp.Documents.Open("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")


    Call ReplaceWords(wdDoc, Wks, False)
    Call CopyPasteImage(wdDoc, Wks, True)
    
    Set wdDoc = Nothing
    Set wdApp = Nothing


End Sub






Sub ReplaceWords(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)


    Dim wdRng       As Word.Range
    Dim varTxt      As Variant
    Dim varRngAddress As Variant
    Dim i           As Long


    varTxt = Split("an1,id1,rd1", ",")
    varRngAddress = Split("C8,C5,C6", ",")


    For Each wdRng In oDoc.StoryRanges


        With wdRng.Find
            For i = 0 To UBound(varTxt)
                .Text = varTxt(i)
                .Replacement.Text = Wks.Range(varRngAddress(i)).Value
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            Next i
        End With


    Next wdRng


    oDoc.SaveAs2 Environ("UserProfile") & "\desktop\001 Electrical works RA " & Format(Now, "yyyy-mm-dd hh-mm-ss")
    If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
    End If


End Sub






Sub CopyPasteImage(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)


    With oDoc
        .Activate


        .ActiveWindow.View = wdNormalView
        Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("CompanyLogo").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph




        Wks.Range("N10:O14").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ConsulSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph


        .Save


        If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
        End If


    End With
End Sub

I keep getting an error here any ideas how to fix this?

 .Save

        If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
        End If


    End With
End Sub

Error message:

Run-time error'-2147417848(80010108'):

Automation error
The object invoked has disconnected from its clients.

snb · 08-13-2019, 08:05 AM

try first without all those storyranges:

Sub M_snb()
  sn=range("C5:C8")

  with Getobject("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")
    activesheet.Shapes(1).CopyPicture
    .Paragraphs.Last.Range.PasteSpecial
    activesheet.Shapes(2).CopyPicture
    .Paragraphs.first.Range.PasteSpecial
     .Application.Selection.HomeKey 6

    .Find.execute "an1", , , , , , , , ,sn(1,4),2
    .find.execute "id1", , , , , , , , ,sn(1,1),2
    .find.execute  "rd1", , , , , , , , ,sn(1,2),2

   .SaveAs2 "C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx"
   .Close 0
  end with
End Sub

**ChrisATBAse** · 08-14-2019, 01:59 AM

Thanks for the revision, I tried it and still ran into the same issue also when the images are copied from excel they aren't copied to the bookmark locations.

snb · 08-14-2019, 07:01 AM

You will have to adapt the code:

Sub M_snb()
  sn = Range("C5:C8")

  With GetObject("G:\OF\voorbeeld.docx")
    .Windows(1).Visible = True
    ActiveSheet.Shapes(1).CopyPicture
    .Paragraphs.Last.Range.PasteSpecial
    ActiveSheet.Shapes(2).CopyPicture
    .Paragraphs.First.Range.PasteSpecial
     .Application.Selection.HomeKey 6

    For Each it In .storyranges
    it.Find.Execute "an1", , , , , , , , , sn(1, 1), 2
    it.Find.Execute "id1", , , , , , , , , sn(3, 1), 2
    it.Find.Execute "rd1", , , , , , , , , sn(4, 1), 2
    Next
    
   .SaveAs2 "G:\OF\voorbeeld_001.docx"
   .Close 0
  End With
End Sub

**Kenneth Hobs** · 08-14-2019, 07:28 AM

In post #9, you had already closed the doc and quit word by the True in the 2nd called routine. Whether to close the doc and quit Word is up to you.

Maybe:

Sub ReplaceWordAndCopyPasteImage()

    Dim wdApp       As Word.Application
    Dim Wks         As Excel.Worksheet
    Dim wdDoc       As Word.Document


    Set Wks = ActiveSheet


    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error Goto 0
    wdApp.Visible = True


    Set wdDoc = wdApp.Documents.Open("C:\Users\Admin\Google Drive\SMS TEMPLATES\02 RISK ASSESSMENTS\001 Electrical works RA.docx")


    Call ReplaceWords(wdDoc, Wks, False)
    'Call CopyPasteImage(wdDoc, Wks, True)
    CopyPasteImage wdDoc, Wks, False
    
    On Error Resume Next
    wdDoc.Close
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing


End Sub

Thread: Word Document Vba Excel - Combing two different codes

Thread Tools

Display

Word Document Vba Excel - Combing two different codes

Tags for this Thread

Posting Permissions