Const wrdDocPath = "Y:\Test.docx"
Sub Uebertragung()
Dim wrdApp As New Word.Application
Dim par As Word.Paragraph
Dim rng As Word.Range
Dim wrdDoc As Word.Document
Set wrdDoc = wrdApp.Documents.Open(wrdDocPath)
wrdApp.Visible = True
wrdApp.Activate
With wrdDoc
Set par1 = .Range(.Range.End - 1).Paragraphs.Add
Set par2 = .Range(.Range.End - 1).Paragraphs.Add
Set par2 = .Range(.Range.End - 1).Paragraphs.Add
Set rng = par1.Range
rng.Text = Tabelle1.Range("A18")
rng.Font.Name = "Arial"
rng.Font.Size = 12
rng.Bold = True
rng.Font.Underline = wdUnderlineSingle
Set rng = Nothing
Set rng = par2.Range
rng.Text = Tabelle1.Range("B18")
rng.Font.Name = "Arial"
rng.Font.Size = 8
End With
wrdDoc.Save
wrdDoc.Close
wrdApp.Quit
End Sub