Mit Excel VBA in Word arbeiten

[Marcel_82]

Hallo 

Eine andere Möglichkeit wäre noch ich füge die Urkunden in ein neues Dokument ein, hier habe ich aber das Problem mit den ganzen Formatierungen (Blattgröße, Ausrichtung, Seitenränder usw.) gäbe es denn die Möglichkeit diese Formatierungen beim Datei einfügen mit zu übernehmen?

grüße Marcel

[Marcel_82]

Hallo zusammen

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

ich danke euch allen für die Hilfe und die nützlichen Tipps.

Schöne Grüße Marcel