Option Explicit
Sub Namensliste_DocsPerTemplateErzeugen()
->Definition
->!!!!!!! A N P A S S E N !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Const c_EXCEL_NAMENSLISTE = c:\Test_Namensliste\Namenliste.xls
Const c_ERSTEWERTEZEILE = 1
Const c_SP_Name = 1->Spalte A
Const c_DOC_TEMPLATE = c:\Test_Namensliste\VorlageNamen.doc
Const c_TEXTMARKE = NameErsetzen
Const c_DOC_OUTPUT = c:\Test_Namensliste\Output
->im VB-Editor unter Extras->Verweise-> Microsoft Word x.0 Object Library einbinden
->(das x hängt von deiner Word-Version ab)
->!!!!!!! A N P A S S E N !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim wb As Workbook, ws As Worksheet
Dim wrdApp As Word.Application, wrdDoc As Word.Document
Dim l_zeile As Long, s_Name As String
->Dateien und Pfade auf Existenz prüfen
If Dir(c_EXCEL_NAMENSLISTE, vbNormal) = Then
MsgBox (Excel-Namensliste ist nicht vorhanden. & vbLf & c_EXCEL_NAMENSLISTE)
Exit Sub
End If
If Dir(c_DOC_TEMPLATE, vbNormal) = Then
MsgBox (Doc-Template ist nicht vorhanden. & vbLf & c_DOC_TEMPLATE)
Exit Sub
End If
If Dir(c_DOC_OUTPUT, vbDirectory) = Then
MsgBox (Output-Dirrectoy ist nicht vorhanden. & vbLf & c_DOC_OUTPUT)
Exit Sub
End If
->Excel-Namensliste öffnen
Set wb = Workbooks.Open(FileName:=c_EXCEL_NAMENSLISTE)
->erstes Blatt ist Namensliste
Set ws = wb.Worksheets(1)
->Word-Instanz öffnen
Set wrdApp = CreateObject(Word.Application)
->Namen abarbeiten
l_zeile = c_ERSTEWERTEZEILE
Do
s_Name = ws.Cells(l_zeile, c_SP_Name).Value
If s_Name = Then Exit Do->leerer Name -> Listeende
->Vorlagen-Datei öffnen
Set wrdDoc = wrdApp.Documents.Open(FileName:=c_DOC_TEMPLATE)
->Textmarke durch Namen ersetzen
On Error Resume Next
wrdDoc.Bookmarks(c_TEXTMARKE).Range.Text = s_Name
If Err.Number <> 0 Then
Err.Clear
wrdDoc.Close Savechanges:=False
MsgBox (Textmarke konnte nicht ersetzt werden.)
GoTo AUFRAEUMEN
End If
->Datei im Output unter Namen als .doc speichern
wrdDoc.SaveAs _
FileName:=c_DOC_OUTPUT & \ & s_Name & .doc, _
FileFormat:=wdFormatDocument
wrdDoc.Close Savechanges:=False
->nächste Zeile in Excel-Namensliste
l_zeile = l_zeile + 1
Loop
AUFRAEUMEN:
->Word schliessen
wrdApp.Quit
->Objekt-Variable löschen
Set wrdDoc = Nothing: Set wrdApp = Nothing
->Excel-Namenliste schliessen
wb.Close Savechanges:=False
Set wb = Nothing: Set ws = Nothing
End Sub
