Word Document Vba Excel - Changing Information in Multiple Documents

[ChrisATBAse]

Hi everyone,

New to coding so I would really appreciate the help.

I need help adjusting the macro below. I have a lot of template Word Documents that I need to make changes to and doing a macro for each file is very time consuming. Is there a way I can edit the macro below to let me select a folder path and loop through each of the files in the folder, make the change and save in new destination?





Sub Cement()

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


Set Wks = ActiveSheet


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

Set wdDoc = wdApp.Documents.Open(Environ("UserProfile") & "\Google Drive\SMS TEMPLATES\04 COSHH\001 Cement.docx")

Call ReplaceWords2(wdDoc, Wks, False)
Call CopyPasteImage2(wdDoc, Wks, False)

wdApp.Quit



Set wdDoc = Nothing
Set wdApp = Nothing


End Sub




Sub ReplaceWords2(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 Cement.docx"
If boolCloseAfterExec Then
oDoc.Close
oDoc.Parent.Quit
End If


End Sub




Sub CopyPasteImage2(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


.Save


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

End With
End Sub

[Leith Ross]

Hello ChrisATBase,

This change should to your macro should work...



Sub Cement2()


Dim File As Object
Dim Folder As Object
Dim Path As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim Wks As Worksheet


Set Wks = ActiveSheet


With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Path = .SelectedItems(1)
Else
Exit Sub
End If
End With

With CreateObject("Shell.Application")
Folder = .Namespace(Path)
Set Files = Folder.FolderItems
Files.Filter 64, "*.docx"
End With

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

For Each File In Files
Set wdDoc = wdApp.Documents.Open(File)
Call ReplaceWords2(wdDoc, Wks, False)
Call CopyPasteImage2(wdDoc, Wks, False)
wdDoc.Close SaveChanges:=True
Next File

wdApp.Quit


End Sub

[ChrisATBAse]

Hi Leith,

Thanks for responding. I tried the code but got an error in the area highlighted red. Any idea how to fix this?

run time error '91':

Object variable or with block variable not set




With CreateObject("Shell.Application")
Folder = .Namespace(Path)
Set Files = Folder.FolderItems
Files.Filter 64, "*.docx"



Also I have multiple files under different names in the folder how should i adapt this part of the code to accommodate for that?



Next wdRng

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

[Leith Ross]

Hello ChrisATBase,

Sorry about that, There should be Set statement before Folder. Here is the corrected macro code...


Sub Cement2()

Dim File As Object
Dim Folder As Object
Dim Path As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim Wks As Worksheet

Set Wks = ActiveSheet

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Path = .SelectedItems(1)
Else
Exit Sub
End If
End With

With CreateObject("Shell.Application")
Set Folder = .Namespace(Path)
Set Files = Folder.FolderItems
Files.Filter 64, "*.docx"
End With

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

For Each File In Files
Set wdDoc = wdApp.Documents.Open(File)
Call ReplaceWords2(wdDoc, Wks, False)
Call CopyPasteImage2(wdDoc, Wks, False)
wdDoc.Close SaveChanges:=True
Next File

wdApp.Quit

End Sub