Text von Excel an Word Textmarken übergeben
21.11.2017 16:34:43
Excel
ich lese schon seit geraumer Zeit die Beiträge in diesem Forum, da ich hier fast zu jedem Problem bislang eine Lösung gefunden habe. Leider komme ich im Moment absolut nicht weiter. Ich möchte mit meinem Makro den Text aus verschiedenen Textfelder an Textmarken in einem Word-Dokument übergeben. Ich muss zugeben, dass ich den Code größtenteils aus dem Internet habe (kann ehrlich nicht mehr sagen, woher)....
Wenn ich den Code so wie unten dargestellt ausführe, kommt die Fehlermeldung "Objekt erforderlich". Teilweise kommt zusätzlich beim Versuch die nun geöffnete Vorlage zu schließen noch die Abfrage, ob die Normal.dotm gespeicher werden soll. Ich weiß wirklich nicht mehr weiter...
Hier der Code:
Sub Kundenanschreiben2()
Dim appWord As Object
Dim docWord As Object
Dim xWordLiefNicht As Boolean
Dim iRow As Long
Dim Marke As String
Dim strBookmark As String
On Error Resume Next
Set appWord = GetObject(, "Word.Application")
On Error GoTo errorMsgWord
Err.Clear
'Verhindern, dass eine zweite Instanz von Word gestartet wird
If appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
xWordLiefNicht = True
End If
Set docWord = appWord.Documents.Add(ThisWorkbook.Path & "\Vorlagen\Vorlage_Kundenanschreiben. _
dotx")
appWord.Visible = True
iRow = 2
Do Until IsEmpty(ThisWorkbook.Sheets(2).Cells(iRow, 1))
strBookmark = ThisWorkbook.Sheets(2).Cells(iRow, 2)
If Not docWord.Bookmarks.Exists(strBookmark) Then
iRow = iRow + 1
Else
If Spalte_Aktionsdatenbank.Value = 10 Then
Marke = ThisWorkbook.Sheets(1).Cells(Zeile_Aktionsdatenbank, Spalte_Aktionsdatenbank) _
_
Marke = Mid(Marke, 5)
docWord.Bookmarks(strBookmark).Range = Marke
Else
Spalte_Aktionsdatenbank = ThisWorkbook.Sheets(2).Cells(iRow, 4).Value
docWord.Bookmarks(strBookmark).Range = ThisWorkbook.Sheets(1).Cells( _
Zeile_Aktionsdatenbank, Spalte_Aktionsdatenbank)
iRow = iRow + 1
End If
End If
Loop
'speichern
docWord.SaveAs Filename:=ThisWorkbook.Path & "\test.docx"
'schließen
docWord.Close
Set docWord = Nothing
If xWordLiefNicht Then
appWord.Quit
End If
Set appWord = Nothing
Exit Sub
errorMsgWord:
MsgBox Err.Description, 16, "Error"
Set docWord = Nothing
Set appWord = Nothing
End Sub
Ich wäre euch sehr dankbar, wenn ihr mir weiterhelfen könntet. Vielen Dank schon einmal.Gruß
Jan