Hallo,

oh ja, teufel, da hab ich ein Font-Objekt übersehen, hab dafür nochmal ein paar Eig. drangehängt, so müsste es was werden...

Option Explicit

Private Sub CommandButton1_Click()
   Dim oExcelApp As Object
   Dim oExcelWorkbook As Object
   Dim lZeile As Long
   Dim objRange As Range
   If ListBox1.ListIndex >= 0 Then
      
         Set oExcelApp = CreateObject("Excel.Application")
         Set oExcelWorkbook = oExcelApp.Workbooks.Open(sBeispiel)
      
         lZeile = 2
         With oExcelWorkbook.Sheets(sTabellenblatt)
                Do While .Cells(lZeile, 1) <> ""
                    If ListBox1.Text = CStr(.Cells(lZeile, 2).Value) Then
                        Set objRange = ActiveDocument.Bookmarks("Textmarke_Name ").Range
                        With .Cells(lZeile, 2)
                            objRange.Text = CStr(.Value)
                            Call Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
                        End With
                        Set objRange = ActiveDocument.Bookmarks("Textmarke_ID").Range
                        With .Cells(lZeile, 1)
                            objRange.Text = CStr(.Value)
                            Call Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
                        End With
                        Set objRange = ActiveDocument.Bookmarks("Textmarke_Beschreibung").Range
                        With .Cells(lZeile, 3)
                            objRange.Text = CStr(.Value)
                            Call Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
                        End With
                        Set objRange = Nothing
                        Exit Do
                    End If
                    lZeile = lZeile + 1
                Loop
         End With
         
         oExcelWorkbook.Close False
         oExcelApp.Quit
      
     Else
         MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
             vbInformation + vbOKOnly, "HINWEIS!"
         Exit Sub
     End If
 
    Set oExcelWorkbook = Nothing
    Set oExcelApp = Nothing
    Unload Me
End Sub

Private Sub Font_Transfer(ByRef probjWdFont As Font, ByRef probjXlFont As Object)
With probjXlFont
     probjWdFont.Color = .Color
     probjWdFont.Bold = .Bold
     probjWdFont.Name = .Name
     probjWdFont.Italic = .Italic
     probjWdFont.Underline = GetFontUnderline(pvlngXlUnderline:=.Underline)
End With
End Sub

Private Function GetFontUnderline(ByVal pvlngXlUnderline As Long) As WdUnderline
   Const xlUnderlineStyleNone As Long = -4142
   Const xlUnderlineStyleSingle As Long = 2
   Const xlUnderlineStyleDouble As Long = -4119
   Select Case pvlngXlUnderline
      Case Is = xlUnderlineStyleNone: GetFontUnderline = wdUnderlineNone
      Case Is = xlUnderlineStyleSingle: GetFontUnderline = wdUnderlineSingle
      Case Is = xlUnderlineStyleDouble: GetFontUnderline = wdUnderlineDouble
   End Select
End Function

Gruß,