Dim AppWDTextmarken As Object
 
Dim wdApp As Object 'Die Word Application
 
Dim wDoc As Object 'Das Word Dokument bzw. geöffnete Seite
 
On Error Resume Next
 
Set wdApp = GetObject(, "Word.Application")
 
On Error GoTo 0
 
If wdApp Is Nothing Then
 
Set wdApp = CreateObject("Word.Application")
 
wdApp.Visible = True
 
End If
 
wdApp.documents.Add
 
Set wDoc = wdApp.ActiveDocument
 
Set AppWDTextmarken = CreateObject("Word.Application") 'Word als Object starten
 
AppWDTextmarken.Visible = True
 
AppWDTextmarken.documents.Open
Sheets("Einstellungen").Range("C10").Value & "\" &
Sheets("Einstellungen").Range("B10").Value & ".docx"
 
Dim strVar As String
 
Dim TMRange As Range
 
Dim TM As String
 
'Variablen mit Werten füllen
 
strVar = AppWDTextmarken.ActiveDocument.Bookmarks(Sheets( _
  "Prüferstellung").Range("D17").Value).Range.Text
 
TM = Sheets("Prüferstellung").Range("D17").Value
 
'Textmarke füllen und neu setzen
 
If AppWDTextmarken.ActiveDocument.Bookmarks.Exists(TM) Then
 
Set TMRange = AppWDTextmarken.ActiveDocument.Bookmarks(TM).Range
 
'Rangeobjekt einen Wert zuweisen
 
TMRange = strVar
 
'Textmarke mit dem wert setzen
 
wdApp.ActiveDocument.Bookmarks.Add TM, AppWDTextmarken.ActiveDocument.Bookmarks( _
  TM).Range
 
Else
 
Fehlermeldung, wenn es die Textmarke nicht gibt
 
MsgBox "Textmarke konnte nicht gesetzt werden!"'
End If

Dim rng As Range
' AppWDTextmarken.ActiveDocument.Bookmarks(Sheets("Prüferstellung").Range( 
' "D17").Value).Range.Copy
 
AppWDTextmarken.ActiveDocument.Bookmarks(Sheets("Prüferstellung").Range( _
  "D17").Value).Range.Copy
 
rng.Paste
rng.Font.Hidden = False
wdApp.ActiveDocument.Bookmarks.Add Sheets("Prüferstellung").Range("D17").Value, _
  rng

Sub WordDokumentErstellen2()
Dim WordApp As Object 'Die Word App
Dim WordQuellDatei As Object 'Die Word Quelldatein mit Textmarken
Dim WordZielDatei As Object 'Die neu erstellte Zieldatei
Dim TextmarkenName As String
Dim rngBereich As Range
TextmarkenName = "NameTextmarke"
'Prüfe ob Word bereits geöffnet ist. Wenn ja dann greife darauf zu und wenn 
' nicht dann gehe weiter
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
 
'Wenn noch kein Dokument offen dann öffne ein neues
If WordApp Is Nothing Then
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
 
'Erstelle ein neues Word-Dokument
WordApp.Documents.Add
'Weise das neue Dokument als WordZielDatei zu
Set WordZielDatei = WordApp.ActiveDocument
 
'Hier können dann Parameter zur Formatierung mit With wdApp.Selection eingefügt 
' werden
 
'Hier wird die Textmarken Datei geöffnet
WordApp.Documents.Open Sheets("Einstellungen").Range("C10").Value & "\" & _
  Sheets("Einstellungen").Range("B10").Value & ".docx"
'Hier die Word-Textmarkendatei an WordQuellDatei binden
Set WordQuellDatei = WordApp.ActiveDocument
 
If WordQuellDatei.Bookmarks.Exists(TextmarkenName) Then
MsgBox WordQuellDatei.Bookmarks(TextmarkenName).Range
Set rngBereich = WordQuellDatei.Bookmarks(TextmarkenName).Range
rngBereich.Copy
WordZielDatei.Range(Start:=WordZielDatei.Content.End - 1, _
  End:=WordZielDatei.Content.End - 1).Paste
End If
 
 
End Sub

Set rngBereich = WordQuellDatei.Bookmarks(TextmarkenName).Range

Dim rngBereich As Word.Range