Word Document Vba Excel - Changing Information in Multiple Documents

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?

Code:

---


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

---

Hello ChrisATBase,

This change should to your macro should work...

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")
            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

---

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

Code:

---

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?

Code:

---

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

---

Hello ChrisATBase,

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

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

---