SafeConstruct
Gebruiker
- Lid geworden
- 23 apr 2021
- Berichten
- 84
Ik wil mijn fakturatieprogramma finaliseren en heb nog 1 vraag waar ik eenvoudig (lees automatisch) na het lanceren van een macro een aantal welbepaalde cellen vanuit xlsx wil kopiëren naar mijn .doc.
Het te kopiëren bereik in xlsx situeert zich van cel B3 tot E7.
Het bereik is te plaatsen in .doc aangeduid in een tabel in gele kleur.
De macro die gelanceerd wordt in .doc heeft als bedoeling een automatische verzendlijst lanceren (wat lukt).
Het te kopiëren bereik in xlsx situeert zich van cel B3 tot E7.
Het bereik is te plaatsen in .doc aangeduid in een tabel in gele kleur.
De macro die gelanceerd wordt in .doc heeft als bedoeling een automatische verzendlijst lanceren (wat lukt).
Code:
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