Word Document Vba Excel - Combing two different codes

[ChrisATBAse]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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