Mailmerge VBA werkt maar moet met variable sheets en brieven

[anton54]

Forumleden,

Mijn VBA macro werkt goed maar we hebben 1 eerste brief , 2e brief , eventueel mail
daarnaast staat de data verdeel over 5 codes maw ik heb dus 1 sheet met naw + 1sheet met herinneringen 1 sheet met mail en dat maal 5

Mijn macro vraagt in de SQL code om een sheet(BriefB NAW)

Nu is het wel mogelijk om 15 knoppen te maken voor ieder sheet 1 maar dan is de macro wel erg groot

De vraag is is het mogelijk om met een inputbox de juiste Brief te kiezen en in de SQL code de juiste sheet toe te voegen/ vervangen toe te voegen

[JS]Sub RunMerge()

Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
' Word constants
Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16

On Error Resume Next

Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wdocSource = wd.Documents.Open("Z:\1e-Email-Brief-alletalenBuitenland.docx")

strWorkbookName = "X:\brievengenerator.xlsm"

wdocSource.MailMerge.MainDocumentType = wdFormLetters

wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & strWorkbookName & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Jet OLEDBatabase Locking Mode=0;Jet OLE", _
SQLStatement:="SELECT * FROM `'BriefB NAW$'`", SQLStatement1:="", _
SubType:=wdMergeSubTypeAccess



With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With

wd.Visible = True
wdocSource.Close savechanges:=False
wd.ActiveDocument.Close savechanges:=False

Set wdocSource = Nothing
Set wd = Nothing

End Sub[/JS]

 

[OctaFish]

Zoiets al geprobeerd?

Dim strWorkbookName As String, sDoc As String
    sDoc = InputBox("Typ de bestandsnaam", "Brief invoeren", "BriefB NAW")
    wdocSource.MailMerge.OpenDataSource Name:=strWorkbookName, AddToRecentFiles:=False, Revert:=False, _
        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" _
        & strWorkbookName & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
        & "Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLE", _
        SQLStatement:="SELECT * FROM `'" & sDoc & "'`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess

 

[anton54]

Sorry maar dan kan hij zijn table niet vinden , begrijp niet waarom

En hij loopt vast op wdocSource

 

[OctaFish]

Doe er eens wat bestanden bij, dat kijkt een stuk makkelijker. Twee brieven is uiteraard wel genoeg om te testen .

 

[anton54]

Octafish

Bijgaand de gevraagde bestanden - mailmerge zal niet werken omdat de directory niet klopt
Module had ik al eerder gestuurd


ik hoop dat je zo genoeg hebt

Bijvoorbaat dank voor je hulp


Vriendelijke groet
Anton