Forum Discussion

brambennink's avatar
brambennink
Copper Contributor
Oct 10, 2024

Won't make and paste over in word document

Im trying to make a macro to copy the content of existing word documents into a newly made one. When I run it in seperate pieces it works, but when i put it together it won't make a new document and ...
excel
Macros and VBA
HansVogelaar's avatar
HansVogelaar
MVP
Oct 10, 2024

brambennink 

Does it work better if you don't activate the documents?

Sub button1()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim newWdDoc As Object
    Dim path As String
    Dim docContent As Object

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

    Set newWdDoc = wdApp.Documents.Add

    If Sheets("Keuze").Cells(2, 2).Value = True Then

        path = Sheets("Verwijzing").Cells(1, 1).Value
        Set wdDoc = wdApp.Documents.Open(path)

        wdDoc.Content.Copy
        newWdDoc.Content.Paste

        wdDoc.Close False
    End If

    If Sheets("Keuze").Cells(2, 3).Value = True Then

        path = Sheets("Verwijzing").Cells(1, 2).Value
        Set wdDoc = wdApp.Documents.Open(path)

        wdDoc.Content.Copy
        newWdDoc.Content.Paste

        wdDoc.Close False
    End If

    If Sheets("Keuze").Cells(2, 4).Value = True Then
        path = Sheets("Verwijzing").Cells(1, 3).Value
        Set wdDoc = wdApp.Documents.Open(path)

        wdDoc.Content.Copy
        newWdDoc.Content.Paste

        wdDoc.Close False
    End If

    newWdDoc.SaveAs2 "C:\Users\User\Documenten\Word\newWdDoc"

    newWdDoc.Close False
    wdApp.Quit

    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set newWdDoc = Nothing
End Sub

P.S. If more than one of the cells on the Keuze sheet is TRUE, each paste will overwrite the previous one.

  • brambennink's avatar
    brambennink
    Copper Contributor
    Oct 11, 2024
    Hey Hans,
    It does the same thing as before.
    And thanks for the heads up about the override, ill look into that.
    • HansVogelaar's avatar
      HansVogelaar
      MVP
      Oct 11, 2024

      brambennink 

      I'm afraid I don't know why the code causes an error.

      • brambennink's avatar
        brambennink
        Copper Contributor
        Oct 16, 2024

        HansVogelaar
        I started (mostly) over and also took your hint about te override and gave that a thought.
        I made a new one and it works as intended. 


        Thanks for the help and insight Hans

        Sub Make()
    Dim Vul As Worksheet
    Dim Link As Worksheet
    
    Set Vul = ThisWorkbook.Sheets("Make") 
    Set Link = ThisWorkbook.Sheets("Hyperlink") 
    
    If Vul.range("E6").value = 0 Then
        MsgBox "Geen Documenten geselecteerd"
        Exit Sub 'stopt de rest van de sub
    End If
    
    Dim wordApp As Object
    Dim docA1 As Object
    Dim filePathA1 As String

        filePathA1 = Link.range("A1").value
    
    Set wordApp = CreateObject("Word.Application") 
    Set docA1 = wordApp.Documents.Open(filePathA1) 

    If Vul.range("B2").value = True Then 
    
        Dim docA2 As Object
        Dim filePathA2 As String
        filePathA2 = Link.range("A2").value
        Set docA2 = wordApp.Documents.Open(filePathA2)

        docA2.content.Copy
        docA1.content.InsertAfter vbCr 
        docA1.Paragraphs.Last.range.Select 
        wordApp.Selection.InsertBreak Type:=2 

        wordApp.Selection.Paste 
        docA2.Close False 
    End If
    
    If Vul.range("B3").value = True Then 
    
        Dim docA3 As Object
        Dim filePathA3 As String
            filePathA3 = Link.range("A3").value
        Set docA3 = wordApp.Documents.Open(filePathA3) 
            docA3.content.Copy 
          
            docA1.content.InsertAfter vbCr 
            docA1.Paragraphs.Last.range.Select 
            wordApp.Selection.InsertBreak Type:=2 

            wordApp.Selection.Paste
            docA3.Close False 
    End If
    
    If Vul.range("B4").value = True Then
    
        Dim docA4 As Object
        Dim filePathA4 As String
            filePathA4 = Link.range("A4").value
        Set docA4 = wordApp.Documents.Open(filePathA4)

            docA4.content.Copy

            docA1.content.InsertAfter vbCr 
            docA1.Paragraphs.Last.range.Select 
            wordApp.Selection.InsertBreak Type:=2 

            wordApp.Selection.Paste 
            docA4.Close False
    End If
 '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
        '!!Hier uitbreiden door "If" t/m "End If" hierboven te copieëren (en plakken) en alle 4 naar 5 te veranderen!!
 
 '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        wordApp.Visible = True 
    
    Dim savePath As String
    Dim fileName As String
    Dim folderPath As String
    
        fileName = Vul.range("E3").value
        folderPath = Vul.range("E5").value
    
    If fileName = "" Then 
        MsgBox "!Geen bestandsnaam opgegeven, bestand wel gemaakt maar niet opgeslagen!"
        Exit Sub
    End If
        
    If folderPath = "" Then
        MsgBox "!Geen opslaglocatie opgegeven, bestand wel gemaakt maar niet opgeslagen!"
        Exit Sub
    End If
    
        savePath = folderPath & "\" & fileName & ".docx"

    Set wordApp = CreateObject("Word.Application")

        docA1.SaveAs2 savePath 
    
        Vul.range("E4").value = Vul.range("E3").value 
                
        MsgBox "Opgeslagen onder bestandsnaam: " & fileName
        Vul.range("E3").ClearContents
    
End Sub


         

Resources