Mit Excel VBA in Word arbeiten

[Marcel_82]

Schönen guten Tag,
 
Ich möchte Aus Excel heraus mehrere Urkunden drucken
Die Urkundenvorlage ist einer doc gespeichert.
 
Ich Öffne aus Excel heraus die doc Datei und speicher sie unter neuen Namen ab. Danach fülle die entsprechenden Felder mit den Daten aus Excel. Das funktioniert. 
Jetzt sollen die weiteren Urkunden in die selbe Datei gespeichert werden.
 
Wie das von Hand geht ist mir bewusst. In dem Reiter Einfügen – Objekt – Text aus Datei . Das Funktioniert auch nur wie bekomme ich das Automatisch hin?
 

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

'Word sichtbar machen
wordapp.visible = True

Zeile = Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row

    'Word-Datei öffnen
    Set doc = wordapp.Documents.Open(Sheets("Einstellungen").Range("B17").Value)

    'Word-Datei abspeichern
    doc.SaveAs2 ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx"
   
    Set doc = wordapp.Documents.Open(ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx")

For Zeile = 5 To Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row

    '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
       
    If Zeile < Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row Then
   
        With oWord
            Selection.InsertFile Filename:=Sheets("Einstellungen").Range("B17").Value, _
             Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
        End With
    End If

Next Zeile

'Word-Datei schließen
doc.Close SaveChanges:=True

'Word-Applikation schließen
wordapp.Quit

End Sub

Ich finde keine Lösung wie ich diesen Teil des Codes zum laufen bringe.

        With oWord

            Selection.InsertFile Filename:=Sheets("Einstellungen").Range("B17").Value, _
             Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
        End With 

für den roten Bereich sagt es mir Fehler 438


Könnten sie mir vielleicht einen Tipp geben wie ich das Word dokument ansprechen muss?
 
Ich würde mich sehr über eine Antwort freuen.
 
 
Mit freundlichen Grüßen
Marcel

[derHoepp]

Moin,

gibt es einen speziellen Grund, warum du das Problem nicht mit einem Seriendruckdokument löst? Das ließe sich natürlich auch aus #xcel heraus steuern. Dann sparst du dir das suchen, ersetzen und Einfügen gänzlich.

Ansonsten lässt sich zu deinem konkreten Problem nur sagen, dass das Selection-Hilfsobjekt ohne weitere Referenz auf ein Word-Objekt ein Excel-Selection-Objekt darstellt, dass für gewöhnlich keine Word-Eigenschaften und -Methode bereitstellt.

Viele Grüße
derHöpp

[26865]

Setz mal einen Punkt vor Selection.

[Marcel_82]

Hallo derHöpp

Das man aus excel heraus auch einen Seriendruck starten kann wusste ich nicht. ich kannte es nur so das man das word öffnen muss dann dort die excel datei auswählen für die Liste 

wie es aus excel heraus geht weiß ich nicht. deswegen war das mein ansatz.


den punkt vor selection habe ich auch schon probiert, da kommt fehler 91


grüße Marcel

[Kuwer]

Hallo Marcel,

dann vielleicht mit With doc und dem Punkt?

Gruß Uwe

[Marcel_82]

hallo Uwe

bei with doc und dem punkt kommt wieder der Fehler 438.

ich habe jetzt mal nach dem Serienbrief geschaut. das wäre zwar eine Möglichkeit aber für die späteren Anwender zu kompliziert. weil dann im Word noch die Felder gesetzt werden müssen usw.
 es wäre schon gut wenn es so gehen würde.

meine Vermutung ist ja das hinter das oWord noch etwas hin muss, wie bei oContent.Find

grüße Marcel

[Kuwer]

Hallo Marcel,

dann bliebe ja nur noch

Code:

        With wordapp
            .Selection...

Gruß Uwe

Siehe auch mal da: Zugriff auf andere Anwendungen (1) - Grundlagen und Irrtümer

[Marcel_82]

Hallo Uwe,

genau das war es, super danke dir.

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

'Word sichtbar machen
wordapp.visible = True

Dim wdDateiName
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


Zeile = Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row

    'Word-Datei öffnen
    Set doc = wordapp.Documents.Open(Sheets("Einstellungen").Range("B17").Value)

    'Word-Datei abspeichern
    doc.SaveAs2 ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx"
   
    Set doc = wordapp.Documents.Open(ThisWorkbook.Path & "\Urkunden\Jungen\Urkunden Jungen.docx")

Dim Start As Double
Start = Timer

For Zeile = 5 To Sheets("Endplatzierung").Cells(Rows.Count, 2).End(xlUp).Row

    If Zeile > 5 And 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

Label2.Caption = "Urkunden Jungen fertig erstellt"
''''Word-Datei schließen
'''doc.Close SaveChanges:=True
'''
''''Word-Applikation schließen
'''wordapp.Quit

End Sub

ein "Problem" besteht jetzt aber noch.

die neue Seite wird immer vor der letzten Seite eingefügt. gibt es eine Möglichkeit die immer am Ende der Datei 
Wenn das nicht möglich ist, wie lösche ich die komplette letzte Seite?

Marcel

[derHoepp]

Moin nochmal,

ich hab es mir nochmal durchgelesen. Du hast der Objektvariablen oWord in deinem Codeausschnitt kein Objekt zugewiesen. Daher schlägt natürlich auch der Zugriff auf eine Eigenschaft mit dem . im With-Block fehl.

Das Selection-Hilfsobjekt gibt es sowohl als Unterobjekt des Application-Objekts, als auch des Window-Objekts. doc sollte also das Objekt der Wahl sein. Allerdings empfiehlt es sich immer, nur auf das Hilfosobjekt zuzugreifen, wenn der Anwender tatsächlich in der grafischen Oberfläche eine Auswahl getroffen hat. Im Übrigen solltest du besser über die direkte Ansprache einer Word-Range gehen. Ein Word-Range-Objekt, dass direkt vor der letzten Absatzmarke des "Hauptdokuments" (also ohne Fußzeilen und Kopfzeilen) erhältst du recht zuverlässig mit:

Code:

Dokumentvariable.Range(Dokumentvariable.StoryRanges(wdMainTextStory).End-1)

darauf kannst du dann die .InsertFile-Methode anwenden.

Ich halte das aber weiterhin für Quatsch. Genau das ist die Aufgabe eines Seriendruckdokuments. Und Standardfunktionen durch halbgar gebasteltes zu ersetzen halte ich für falsch. Richtiger wäre es, Anwender in die Nutzung von Standardfunktionen zu unterweisen. Aber selbst wenn dass nicht möglich wäre, wäre es deutlich besser, die eingebaute Funktion einfach fernzusteuern. Da müssen auch keinerlei Felder gesetzt werden, dass ist ja alles in der Dokumentenvorlage enthalten (ich gehe mal davon aus, dass der Anwender jetzt auch nicht die Texte in geschweiften Klammern eingibt, sondern diese Informationen schon in der Vorlage stehen).

Das würde nach diesem Muster funktionieren:

Code:

Option Explicit

Sub UrkundenErzeugen()
    Dim wdapp As Object
    Set wdapp = CreateObject("Word.Application")
    Dim merger As Object
    Dim tempname As String
    tempname = Environ("TEMP") & "\Tempfile.xlsx"
    Set merger = wdapp.Documents.Open("C:\Daten\Serienvorlage.docx")
    ThisWorkbook.SaveCopyAs tempname
    With merger.MailMerge
        .OpenDataSource Name:=tempname, SQLStatement:="Select * From `" & Me.Name & "$`", openexclusive:=False
        .Destination = 0 'wdSendToNewDocument
        .Execute
        Dim dc As Object
        For Each dc In wdapp.Documents
            If dc.Name Like "Serienbrief*" Then
                dc.ExportAsFixedFormat "C:\Daten\Urkunden.pdf", 17 'wdExportFormatPDF
                dc.Close False
                Exit For
            End If
        Next
        .Parent.Close False
    End With
    wdapp.Quit
    Kill tempname
    Debug.Print "done deal"
End Sub

Viele Grüße
derHöpp

[Nachtrag: Die temporäre Kopie ist notwendig, da Word sonst meckert, dass eine xlsm-Datei mit Makros geöffnet werden muss]

[Marcel_82]

Hallo derHöpp

das mit der Dokumentenvorlage ist ja gerade das Problem. Ich weiß nicht in wieweit die Anwender fit sind. Die Urkundenvorlage muss jeder Anwender selber bearbeiten, weil jede Urkunde ja anders von der grafischen Gestaltung ist. Manche nutzen alle geschweiften klammern, die anderen lassen bestimmte geschweifte Klammern weg. Dann werden vielleicht einmal ausversehen Zeilen gelöscht. und dann schreibt man einfach die geschweifte klammer wieder hin und ist fertig.

Bei uns gibt es ein Turnierprogramm das auf die gleiche Weise Urkunden ausfüllt und druckt, deswegen möchte ich mich gerne an dieses Prinzip halten damit man nicht ständig etwas neues beachten muss.

Von dem Programm kenne ich ja den Code nicht und kann auch keine Einzelschritte nachvollziehen wie es funktioniert. ich sehe nur das Endergebnis. und da sind die Urkunden immer der Reihe nach drin. Von 1-50 z.B.

Mit dem Code bekomme ich in der Datei zuerst die Plätze 2-50 und letzte Seite ist Platz 1

Hatte den Code auch schon anders gebastelt dort hatte ich die Datei einfügen kurz vor Next zeile. dann war die Reihenfolge aber Platz1-50 und letzte Seite war nochmal Platz 1

in dem Fall 2 müsste ich am ende des Makros "nur" die letzte Seite komplett löschen. was ich aber auch nicht hinbekomme.

Grüße Marcel