Hallo,

oha, das sagst Du jetzt...;-)...aber ok, dann macht's Sinn...da müssen wir jeden einzelnen Buchstaben durchnuckeln...

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("test1").Range
                        objRange.Text = CStr(.Cells(1, 2).Value)
                        Call Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 2))
                        Set objRange = ActiveDocument.Bookmarks("test2").Range
                        objRange.Text = CStr(.Cells(1, 1).Value)
                        Call Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 1))
                        Set objRange = ActiveDocument.Bookmarks("test3").Range
                        objRange.Text = CStr(.Cells(1, 3).Value)
                        Call Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 3))
                        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 probjWdChars As Characters, ByRef probjXlCell As Object)
Dim objXlFont As Object
Dim lngIndex As Long
With probjXlCell
    For lngIndex = 1 To .Characters.Count
        Set objXlFont = .Characters(Start:=lngIndex, Length:=1).Font
        With probjWdChars.Item(Index:=lngIndex).Font
            .Color = objXlFont.Color
            .Bold = objXlFont.Bold
            .Name = objXlFont.Name
            .Italic = objXlFont.Italic
            .Size = objXlFont.Size
            .Underline = GetFontUnderline(pvlngXlUnderline:=objXlFont.Underline)
        End With
    Next
End With
Set objXlFont = Nothing
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ß,