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.