Serienbrief nach Erstellung speichern
07.04.2022 15:00:21
Julian
ich habe ein Makro, welches aus meiner Excel Tabelle gefiltert einen Serienbrief erstellt. Funktioniert super.
Er öffnet meinen Serienbrief, erstellt ihn, schließt die Hauptdatei und dann bleibt der erzeugte Serienbrief offen.
Frage: wie kann ich jetzt einbringen, dass dieser Serienbrief mit Namen X in Pfad X gespeichert wird?
Option Explicit
Sub zert_eignung()
'-------------------------------------------
Dim ws As Worksheet
Set ws = ActiveSheet
Dim varRange As Excel.Range
Dim filter As Variant
Dim Name As String
Name = (Environ("USERNAME"))
If Name = "Julian" Then
Name = "C:\Users\Julian"
ElseIf Name = "alexa" Then
Name = "C:\Users\alexa"
End If
filter = 1
'
'*pruefe, ob in der Spalte FP ein Eintrag vorhanden ist
Dim intSendezeile As Integer
intSendezeile = 0
Dim intZeile As Integer
For intZeile = 1 To 1000
If ws.Range("FP" & intZeile).Value = 1 Then
intSendezeile = intZeile
Exit For
End If
Next
' check sende1 >
'
If intSendezeile = 0 Then
MsgBox "Es gibt keine Zeile die gesendet werden kann. Alle Zellen in Spalte FP sind leer", vbCritical, "fp_Excel_Word_Serienbrief_erstellen()"
Exit Sub
End If
' Kontrolle >
'*diese Funktion oeffnet den Serienbrief BR-Mittelung
Dim sFilename As String
sFilename = Name & "\OneDrive\XXXXX\100 - Intern\100 - Bestellungen\100 - Orderbuch\Serienbrief" & "\" & "Bescheinigung Eignungstest Serienbrief.docx"
'
'Dim fs As New FileSystemObject
'If fs.FileExists(sFilename) = False Then
' MsgBox "Die Datei existiert nicht" & vbCrLf & "Dateiname:" & sFilename, vbCritical, "fp_Excel_Word_Serienbrief_erstellen()"
' Exit Sub
'End If
' check Document >
'
Dim wordApp As Object 'As New Word.Application 'Word-dll
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
' Word starten >
'
'Dim doc As Object
Dim doc As Word.Document 'word-dll
Set doc = CreateObject("Word.Document")
Set doc = wordApp.Documents.Open(sFilename, ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False)
' Word Document oeffnen >
Dim wb As Workbook
Set wb = ThisWorkbook
Dim sExcel_Filename As String
sExcel_Filename = Name & "\OneDrive\XXXXX\100 - Intern\100 - Bestellungen\100 - Orderbuch\Orderbuch XXXXX.xlsm"
'1
'*Datenquelle für den Seriendruck
If wordApp.Build Like "12*" Then
'--
doc.MailMerge.OpenDataSource Name:=sExcel_Filename _
, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sExcel_Filename & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;Jet OLEDB:Eng;TypeGuessRows=0;" _
, SQLStatement:="SELECT * FROM `Adressen`", SQLStatement1:=" WHERE Anschreiben='1'", SubType:=1
'*subtype:=1=wdMergeSubTypeAccess
'- Ist_Office2007 >-
Else
'--
doc.MailMerge.OpenDataSource Name:=sExcel_Filename, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sExcel_Filename & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;Jet OLEDB:Eng;TypeGuessRows=0;" _
, SQLStatement:="SELECT * FROM `Bestellungen$`", SQLStatement1:=" WHERE Serienbrief='1'", SubType:=1
'*subtype:=1=wdMergeSubTypeAccess
', SQLStatement:="SELECT * FROM 'Bestellungen$'"
' _
, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sExcel_Filename & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;Jet OLEDB:Eng;TypeGuessRows=0;" _
, SQLStatement:="SELECT * FROM `Adressen`", SQLStatement1:=" WHERE Anschreiben''", SubType:=1
'*subtype:=1=wdMergeSubTypeAccess
'- Ist_Office2010 >-
End If
' Datenquelle einstellen >
'
If Err.Number = 9 Then
'Fehler Maric... Update()
Err.Clear
doc.MailMerge.Execute
ElseIf Err.Number 0 Then
MsgBox "Fehler beim Daten holen Word von Excel." & vbCrLf & Err.Description, vbCritical, "fp_Excel_Word_Serienbrief_erstellen()"
Else
doc.MailMerge.Execute
End If
' Serienbrief erzeugen >
'
doc.Close False
' Hauptdocument schliessen >
'-------------------------------------------
End Sub