Option
Explicit
Sub
Textmarken()
Dim
objWDApp
As
Object
, objDocx
As
Object
, TB, Z, ArrWord, Bmark
As
String
, SP
As
Integer
Dim
WPfad
As
String
, WDatei
As
String
, WNeuNam
As
String
ArrWord = Array(
"Bescheinigung"
,
"Artikel"
,
"Menge"
,
"Bauteil"
,
"Hersteller"
, _
"Zeugnis"
,
"Werkstoff"
,
"Charge"
,
"Probe"
,
"Stempelcode1"
,
"Stempelcode2"
)
WPfad =
"C:\Vorlagen"
WDatei =
"USBTest.dotx"
Set
TB = ThisWorkbook.Sheets(
"MATERIALBUCH"
)
WPfad = IIf(Right(WPfad, 1) =
"\", WPfad, WPfad & "
\")
If
Dir(WPfad, vbDirectory) =
""
Then
MsgBox
"Verzeichnis"
& vbLf & vbLf & _
" "
& WPfad & vbLf & vbLf & _
"existiert nicht!"
, vbCritical,
"Allgemeine Verwaltungsfehler"
Exit
Sub
End
If
If
Dir(WPfad & WDatei) =
""
Then
MsgBox
"Vorlagedatei "
& vbLf & vbLf & _
" "
& WDatei & vbLf & vbLf & _
"im Verzeichnis "
& vbLf & vbLf & _
" "
& WPfad & vbLf & vbLf & _
"nicht gefunden!"
, vbCritical,
"Allgemeine Verwaltungsfehler"
Exit
Sub
End
If
Set
objWDApp = CreateObject(
"Word.Application"
)
objWDApp.Visible =
True
Set
objDocx = objWDApp.Documents.Add(WPfad & WDatei)
With
objDocx
For
Each
Z
In
ArrWord
SP = SP + 1
Bmark = Replace(Z,
" "
,
"_"
)
Bmark = Replace(Bmark,
"-"
,
""
)
Bmark = Replace(Bmark,
"("
,
""
)
Bmark = Replace(Bmark,
")"
,
""
)
Bmark = Replace(Bmark,
"/"
,
""
)
Bmark = Replace(Bmark,
"\", "
")
If
.Bookmarks.Exists(Bmark)
Then
_
.Bookmarks(Bmark).Range.Text = TB.Cells(6, SP)
Next
WNeuNam = WDatei &
"_"
& Format(
Date
,
"YYYYMMDD"
) &
".docx"
.SaveAs (WPfad & WNeuNam)
End
With
End
Sub