Ich benutze Word und Excel in der Version 2013. Ich bin über jede Hilfe dankbar.
Public Sub Serienbriefdruck()
Debug.Print "#### Starte Serienbriefdruck!"
On Error GoTo ErrHandler
Dim from As String
Dim tabelle As String
Dim wdApp As Object
Dim dok As Object
Dim name As String
tabelle = ActiveWorkbook.name
'Serienbrief drucken
'Word öffnen
Set wdApp = CreateObject("Word.Application")
'TODO auf False setzen, damit Erstellung im Hintergrund läuft
wdApp.Visible = True
'wdApp.ScreenUpdating = False
'wdApp.DisplayAlerts = False
pfad = Application.ActiveWorkbook.Path & "\"
datei = "Zuweisungen Zeugniskonferenz.docm"
Debug.Print pfad & datei
'Serienbrief öffnen
'MsgBox pfadSerienbrief & serienbrief
Set dok = wdApp.Documents.Open(pfad & datei)
dok.MailMerge.MainDocumentType = 0
dok.MailMerge.MainDocumentType = wdFormLetters
'Serienbrief aufrufen
src = pfad & ActiveWorkbook.name
Debug.Print src
For Each ws In ActiveWorkbook.Worksheets
If ws.name "Vorbereitung" Then
ws.Activate
ActiveSheet.Range("B2").Value = ws.name
Debug.Print ws.name
from = "`" & ws.name & "$" & "`"
' HIER TRITT DER FEHLER AUF...
'dok.MailMerge.OpenDataSource name:=src, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=src;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 OLEDB:Global" _
, SQLStatement:="SELECT * FROM " & from, SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
dok.MailMerge.ViewMailMergeFieldCodes = False
'Serienbrief in eine neue Worddatei ausgeben
' With dok.MailMerge
' .Destination = wdSendToNewDocument
' .SuppressBlankLines = True
'End With
'wdApp.Run "DeleteEmptyRows()"
wdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
pfad & "Zuteilung " & ActiveWorkbook.ActiveSheet.name, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, from:=beginnDS, To:=endeDS, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, BitmapMissingFonts:=True, _
UseISO19005_1:=True
wdApp.ActiveDocument.Close savechanges:=False 'erzeugte Worddatei schliessen?
'wdApp.ScreenUpdating = False
'wdApp.DisplayAlerts = False
End If
Next ws
wdApp.Quit wdDoNotSaveChanges
Set dok = Nothing
Set wdApp = Nothing
Debug.Print "#### Serienbriefdruck abgeschlossen!"
Exit Sub
'Fehlerbehandlung
ErrHandler:
If Err.Number 0 Then
MsgBox "Fehler bei " & _
blatt & vbCrLf & _
CStr(Err.Number) & " " & Err.Description, vbExclamation + vbOKOnly
Debug.Print vbCrLf & CStr(Err.Number) & " " & Err.Description
End If
wdApp.Quit wdDoNotSaveChanges
Set dok = Nothing
Set wdApp = Nothing
End Sub