Consulting

Results 1 to 4 of 4

Thread: Word Document Vba Excel - Changing Information in Multiple Documents

  1. #1

    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?


    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


  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    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
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    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

  4. #4
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    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
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •