Sub PDF_Export()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long
Dim StrFolderExists As String, docName As String
Set MainDoc = ActiveDocument
docName = Left(ActiveDocument.Name, 5)
With MainDoc
StrFolder = .Path & Application.PathSeparator & "PDF" & Application.PathSeparator
StrFolderExists = Dir(StrFolder, vbDirectory)
If StrFolderExists = "" Then
MkDir (StrFolder)
End If
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("NAME1")) = "" Then Exit For
If Trim(.DataFields("NAME1")) = "NAME2" Then Exit For
StrName = docName & .DataFields("BEZEICHNUNG1") & "_" & .DataFields("BEZEICHNUNG2")
End With
.Execute Pause:=False
End With
StrName = Trim(StrName)
With ActiveDocument
.SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
End With
Application.ScreenUpdating = True
End Sub