Office: Formatierung inkl. Textmarken der übertragenen Word-Datei mit über-nehmen

Hallo Zusammen,


ich habe eine Frage, gibt es einen Mako Befehl, der in Excel 1 zu 1 den Inhalt einer ausgewählten Word-Datei inkl. Formatierung und Textmarken in eine andere Word-Datei übertragen kann (Vorher ausgewählt).

Ich habe ein Makro die zwar die Texte in eine andere Word-Datei überträgt, aber nicht 1 zu 1 inkl. Formatierung und Textmarken von der ausgewählten Word-Datei.

Makro:

Option Explicit

Sub WordTexteÜbertargenInWorddatei()
Dim AppWD As Object
Dim fn As Variant
Dim wsDatenbank As Worksheet
Dim wsTabelle1 As Worksheet
Dim i As Integer, cnt&
Dim sDateiPfad$, sDateiname$, rngfund As Range
Dim docZiel As Object, docQuelle As Object
Dim textInhalt As String

' Arbeitsblätter zuweisen
Set wsDatenbank = ThisWorkbook.Sheets("Datenbank")
Set wsTabelle1 = ThisWorkbook.Sheets("Tabelle1")

' Öffnen des Suchfensters für die Ziel-Word-Datei
fn = Application.GetOpenFilename("Word-Dokumente, *.docx", , "Bitte Zieldatei auswählen")
If fn = False Then Exit Sub ' Abbrechen gedrückt

' Word-Anwendung starten
On Error Resume Next
Set AppWD = GetObject(Class:="Word.Application")
If AppWD Is Nothing Then
Set AppWD = CreateObject("Word.Application")
End If
On Error GoTo 0
If AppWD Is Nothing Then MsgBox "Word kann nicht geöffnet werden": Exit Sub

'AppWD.Visible = True
'Zieldatei öffnen
Set docZiel = AppWD.documents.Open(fn)

' Durchlaufen der Dropdowns in Spalte D der Tabelle1
For i = 1 To wsTabelle1.Cells(wsTabelle1.Rows.Count, 4).End(xlUp).Row ' Spalte D
If wsTabelle1.Cells(i, 4).Value <> "" Then ' Nur wenn es einen Wert gibt
sDateiname = wsTabelle1.Cells(i, 4).Value

' Den dateinamen in der Datenbank suchen
Set rngfund = Intersect(wsDatenbank.UsedRange, wsDatenbank.Columns(1)).Find(sDateiname, LookIn:=xlValues, lookat:=xlWhole) ' 1 Spalte rechts

If Not rngfund Is Nothing Then
cnt = cnt + 1
sDateiPfad = rngfund.Offset(0, 1).Value & "\" & sDateiname
Set docQuelle = GetObject(sDateiPfad)
docZiel.Content.InsertAfter vbCr & docQuelle.Content ' Text mit Zeilenumbruch einfügen
docQuelle.Close
Set docQuelle = Nothing

End If

End If
Next i

' Word-Dokument speichern
docZiel.Save
' docZiel.Close
If Not rngfund Is Nothing Then MsgBox "Einfügen von " & cnt & " Blöcken abgeschlossen" Else MsgBox "Nichts zum einfügen ":

'AppWD.Quit
' Aufräumen
Set docZiel = Nothing
Set AppWD = Nothing
Set wsDatenbank = Nothing
Set wsTabelle1 = Nothing
End Sub

Danke für die Hilfe.

 

Hallo Rob,

es ist ein bisschen mühsam, deinem Code zu entnehmen, was du genau beabsichtigst. Aber zu deiner Kernfrage:
Mit docZiel.Content.InsertAfter vbCr & docQuelle.Content überträgst du nur reinen Text. Um Textmarken und Formatierung mitzunehmen, musst du den Quellbereich kopieren. Wenn du - wie ich deinem Code entnehme - das komplette Quelldokument ans Ende deines Zieldokuments anhängen willst, kannst du mit Einfügen > Text aus Datei arbeiten, was so aussehen würde:

Code:

'...
Dim bereich As Range
Set bereich = docZiel.Content
bereich.Collapse direction:=wdCollapseEnd
bereich.InsertFile FileName:=docQuelle
'...