Macro voor kopieren vanuit excel naar word

Sub Verzendlijst()
Dim Naam As String, Map As String
    Map = ZoekMap("C:\Users\Gebruiker\Google Drive\Safe Construct\SC Werven\")
    With ActiveDocument.MailMerge
        With .DataSource
            .FirstRecord = .ActiveRecord
            .LastRecord = .ActiveRecord
            Naam = .DataFields("VGPINFO").Value & ".docx"
        End With
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        .Execute Pause:=False
        ActiveDocument.SaveAs2 FileName:=Map & "\" & Naam, FileFormat:=wdFormatXMLDocument, CompatibilityMode:=15
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="4"
    End With
   
End Sub
Private Function ZoekMap(Optional Startmap As String) As String
'*********************************************************************************
' Early binding: Microsoft Office 11.0 Object Library of later
Dim fDialog As Office.FileDialog
'*********************************************************************************
' Late binding: gebruik objecten
''Dim fDialog As Object
'*********************************************************************************
Dim varFile As Variant
Dim i As Integer

    '******************************************************************************
    'Opzetten File Dialog met Early Binding.
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    '******************************************************************************
    'Opzetten File Dialog met Late Binding.
    'Set fDialog = Application.FileDialog(4)
    '******************************************************************************
    With fDialog
        '**************************************************************************
        'Pas dit aan voor map met afbeeldingen
        .InitialFileName = IIf(Startmap = "", ActiveDocument.Path & "\", Startmap)
        '**************************************************************************
        .AllowMultiSelect = False
        .Title = "Kies een map.."
        '**************************************************************************
        'Toon het scherm, als methode False teruggeeft is er geen map gekozen.
        '**************************************************************************
        If .Show = True Then
            ZoekMap = .SelectedItems(1)
        Else
            ZoekMap = "Geen map geselecteerd."
        End If
    End With
End Function
Sub Save_doc_pdf()
'
' Save_doc_pdf Macro
'
'
Naam = InputBox("Bestandsnaam? ", "Naam")
    ChangeFileOpenDirectory "C:\Users\Gebruiker\Google Drive\DOCS SAVED PDF\"
    ActiveDocument.SaveAs2 FileName:=Naam, FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.ExportAsFixedFormat OutputFileName:=Naam, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
Application.PrintOut FileName:="", Range:=wdPrintRangeOfPages, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="4", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
End Sub