Consulting

Results 1 to 13 of 13

Thread: Word Document Vba Excel - Combing two different codes

  1. #1

    Word Document Vba Excel - Combing two different codes

    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

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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.

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

  4. #4
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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

  5. #5
    VBAX Mentor
    Joined
    Dec 2008
    Posts
    404
    Location
    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

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

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

  8. #8
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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
    Last edited by snb; 08-13-2019 at 06:29 AM.

  9. #9
    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.
    Last edited by ChrisATBAse; 08-13-2019 at 07:46 AM.

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

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

  12. #12
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  13. #13
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    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

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
  •