Sub ExcelInhalt_nach_Word()
Dim oAppWord As Object, oDoc As Object
Dim sPfad As String, sWdDoc As String
sPfad = ThisWorkbook.Path 'Verzeichnis des Worddokuments
sWdDoc = "Test.Doc" 'Name der Worddatei
'Word-Anwendung starten und Dokument öffnen
Application.StatusBar = "Word-Anwendung wird gestartet und Datei geöffnet"
Set oAppWord = CreateObject("Word.Application")
oAppWord.Visible = True
Set oDoc = oAppWord.documents.Open(sPfad & Application.PathSeparator & sWdDoc)
'Inhalt aktive Zelle nach Word an Textmarke "ExcelBetrag"
If ChangeTextMarke(oWordDoc:=oDoc, sWdTextmarke:="ExcelBetrag", _
sText:=ActiveCell.Text) = False Then
MsgBox "Textmarke ""Excelbetrag"" existiert nicht in """ & oDoc.FullName
End If
'Inhalt rechte Nachbarzelle der aktiven Zelle nach Word an Textmarke "ExcelBetrag2"
If ChangeTextMarke(oWordDoc:=oDoc, sWdTextmarke:="ExcelBetrag2", _
sText:=ActiveCell.Offset(0, 1).Text) = False Then
MsgBox "Textmarke ""Excelbetrag2"" existiert nicht in """ & oDoc.FullName
End If
oDoc.Save
oDoc.Close
oAppWord.Quit
Application.StatusBar = False
MsgBox "Wertübertragung abgeschlossen"
End Sub
Function ChangeTextMarke(oWordDoc As Object, ByVal sWdTextmarke As String, ByVal sText) As _
Boolean
Dim oRange As Object
'Fügt in einem Worddokument Text an Textmarke ein bzw. ändert den Text der Textmarke
'oWordDoc = Objekt, das ein Worddokument repräsentiert
'sWdTextmarke = Name einer Textmarke in dem Worddokument
'sText = Text der an der Textmarke eingefügt werden soll
If oWordDoc.bookmarks.Exists(sWdTextmarke) Then
With oWordDoc.bookmarks(sWdTextmarke)
If .Start = .End Then
'Textmarke nur an Einfüge-Position
Set oRange = oWordDoc.Range(.Start, .Start)
oRange.Text = sText
'Textmarke auf Zahlenwert erweitern
oWordDoc.bookmarks.Add sWdTextmarke, _
oWordDoc.Range(.Start, .Start + Len(sText))
Else
'Textmarke für mehrere Zeichen
Set oRange = oWordDoc.Range(.Start, .Start)
oRange.Text = sText
Set oRange = oWordDoc.Range(.Start + Len(sText) - 1, .End)
oRange.Text = ""
End If
End With
ChangeTextMarke = True
Else
ChangeTextMarke = False
End If
End Function
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen