Option
Explicit
Sub
SerienbriefVerknüpfen()
Dim
oWord
As
Object
Dim
oDoc
As
Object
Dim
strLaufwerkDateiname
As
String
Dim
strSerienbrief
As
String
Dim
Projektnr
As
String
Dim
Unterlage
As
String
Projektnr = Cells(2, 2).Value
Unterlage = Cells(3, 2).Value
strSerienbrief =
"Test_Unterlagendeckblatt.docx"
If
strSerienbrief =
""
Then
MsgBox
"Bitte triff eine Auswahl!"
Exit
Sub
End
If
strLaufwerkDateiname = ThisWorkbook.Path & "\Rohdaten\" & strSerienbrief
Dateinamen zusammenfügen
Set
oWord = CreateObject(
"word.application"
)
Set
oDoc = oWord.Documents.Open(strLaufwerkDateiname)
oWord.Visible =
True
oWord.Application.Activate
oDoc.MailMerge.MainDocumentType = 0
Seriendruckdokument an.
oDoc.MailMerge.OpenDataSource Name:= _
ThisWorkbook.FullName _
, ConfirmConversions:=
False
, LinkToSource:=
True
, Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="
""
";User ID=Admin;Data Source="
& _
ThisWorkbook.FullName & _
";Mode=Read;Extended Properties="
"HDR=YES;IMEX=1;"
";Je"
_
, SQLStatement:=
"SELECT * FROM `Unterlagendeckblatt$`"
, SQLStatement1:=
""
, SubType:=1
oDoc.MailMerge.ViewMailMergeFieldCodes = wdToggle
oDoc.SaveAs ThisWorkbook.Path &
"\" & Projektnr & "
_
" & LCase(Unterlage) & "
_udb_
" & Format(Date, "
yyyy-MM-dd
") & "
_Serienbrief"
With
oDoc.MailMerge
.Destination = 0
in ein neues Dokument übertragen.
.SuppressBlankLines =
True
im Seriendruckdokument unterdrückt.
With
.DataSource
.FirstRecord = 1
tzen 1 bis
.LastRecord = -16
End
With
.Execute Pause:=
False
.SaveAs ThisWorkbook.Path &
"\" & Projektnr & "
_
" & LCase(Unterlage) & "
_udb_
" & Format(Date, "
yyyy-MM-dd")
.Close
End
With
oDoc.Close SaveChanges:=0
Set
oDoc =
Nothing
Set
oWord =
Nothing
End
Sub