Ich wollte euch mitteilen das mein Problem jetzt gelöst ist. ich habe eine Lösung gefunden welche das macht, was es soll.
Code:
Sub ExportToWord()
'Bibliothek aktivieren
Dim wordapp As New Word.Application
Dim doc As Word.Document
Dim Zeile As Long
Dim myRange As Range
Dim oWord As Object, oDoc As Object, oContent As Object
Dim n As Variant
Dim Zeit As Variant
Dim wdDateiName
Dim Start As Double
Set wordapp = CreateObject("Word.Application")
'Word sichtbar machen
wordapp.visible = True
wdDateiName = ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx"
On Error Resume Next
Open wdDateiName For Binary Access Read Lock Read As 1
Close #1
If Err.Number = 70 Then
'Datei ist bereits offen
MsgBox "Urkunden Jungen.docx ist bereits geöffnet. bitte schließen und Urkundendruck neu starten"
Exit Sub
End If
On Error GoTo 0
'Word-Datei öffnen
Set doc = wordapp.Documents.Open(Sheets("Einstellungen").Range("B17").Value)
With wordapp
.Selection.WholeStory
.Selection.Delete Unit:=wdCharacter, Count:=1
End With
'Word-Datei abspeichern
doc.SaveAs2 ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx"
Set doc = wordapp.Documents.Open(ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx")
Start = Timer
For Zeile = 5 To Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row
If Zeile <= Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row Then
With wordapp
.Selection.InsertFile Filename:=Sheets("Einstellungen").Range("B17").Value, _
Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
End With
End If
'Word-Datei mit Excel-Daten befüllen
Set oContent = doc.Content
With oContent.Find
.text = "{Jahr}"
.Execute replacewith:=Year(Sheets("Einstellungen").Range("B3").Value), Replace:=2
End With
With oContent.Find
.text = "{Name}"
.Execute replacewith:=Sheets("Endplatzierung").Cells(Zeile, 3).Value & " " & Sheets("Endplatzierung").Cells(Zeile, 2).Value, Replace:=2
End With
With oContent.Find
.text = "{Verein}"
.Execute replacewith:=Sheets("Endplatzierung").Cells(Zeile, 4).Value, Replace:=2
End With
With oContent.Find
.text = "{Klasse}"
.Execute replacewith:="Jungen - Jahrgang " & Sheets("Einstellungen").Range("B7").Value & " und jünger", Replace:=2
End With
With oContent.Find
.text = "{Platz}"
.Execute replacewith:=Sheets("Endplatzierung").Cells(Zeile, 6).Value, Replace:=2
End With
With oContent.Find
.text = "{Ort}"
.Execute replacewith:=Sheets("Einstellungen").Range("B5").Value, Replace:=2
End With
With oContent.Find
.text = "{Datum}"
.Execute replacewith:=Date, Replace:=2
End With
With oContent.Find
.text = "{Leiter}"
.Execute replacewith:=Sheets("Einstellungen").Range("B8").Value, Replace:=2
End With
'' 'Word-Datei als PDF abspeichern
'' doc.ExportAsFixedFormat ThisWorkbook.Path & "\Urkunden\Jungen\Platz " & Sheets("Endplatzierung").Cells(Zeile, 6).Value _
'' & " - " & Sheets("Endplatzierung").Cells(Zeile, 3).Value & " " & Sheets("Endplatzierung").Cells(Zeile, 2).Value & ".pdf", wdExportFormatPDF
''
'' ''Word-Datei schließen
'' doc.Close SaveChanges:=False
If Zeile = 5 Then
Zeit = Format(Timer - Start, "#0.00")
End If
Label2.Caption = "Platz " & Zeile - 4 & " / " & Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row - 4 & " erstellen. Dauer ca. " _
& Zeit * (Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row - Zeile + 1) & " Sekunden"
Next Zeile
With wordapp
.Selection.Goto What:=wdGoToBookmark, name:="\page"
.Selection.Find.ClearFormatting
With .Selection.Find
.text = ""
.Replacement.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Selection.Delete Unit:=wdCharacter, Count:=1
End With
Label2.Caption = "Urkunden Jungen fertig erstellt"
''''Word-Datei schließen
'''doc.Close SaveChanges:=True
'''
''''Word-Applikation schließen
'''wordapp.Quit
End Sub