Hallo,

ok, dann probier mal folgendes, das ist jetzt aus Word programmiert, Deinen Textboxen müssen zwingend TextBox1, TextBox2 und TextBox3 heißen, oder Du änderst das im Code.

Der erste kleine Code-Teil sind Ereignisprozeduren für die Boxen und gehört in Dein Dokument-Modul ('ThisDocument').

Der zweite große Code-Teil gehört in ein Standardmodul (Rechtsklick auf die Module >>> Einfügen >>> Modul).

Option Explicit

Private mstrText As String

Private Sub Document_ContentControlOnEnter(ByVal ContentControl As ContentControl)
mstrText = ContentControl.Range.Text
End Sub

Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
With ContentControl '// Hier Deine TextBox-Namen...
     If .Title = "TextBox1" Then _
       If .Range.Text <> mstrText Then _
          Call Fill_Boxes(pvstrText:=.Range.Text)
End With
End Sub

Option Explicit
Option Private Module

Private lblnTMP As Boolean

Public Sub Fill_Boxes(ByVal pvstrText As String)
 Const FILE_PATH As String = "C:\Users\MyUser\Documents\Excel\"
 Const FILE_NAME As String = "MyExcelFile.xlsx"
 Const xlValues As Long = -4163
 Const xlWhole As Long = 1
 Dim objApp As Object
 Dim objWorkbook As Object
 Dim objCell As Object
 On Error GoTo Sub_Exit
 Set objApp = OffApp("Excel")
 '// folgende Codezeile für Excel nicht sichtbar:
 '// Set objApp = OffApp("Excel", False)
 If Not objApp Is Nothing Then
    For Each objWorkbook In objApp.Workbooks
       If objWorkbook.Name = FILE_NAME Then Exit For
    Next
    If objWorkbook Is Nothing Then _
       Set objWorkbook = objApp.Workbooks.Open(FileName:=FILE_PATH & FILE_NAME)
    Set objCell = objWorkbook.Worksheets(1).UsedRange.Find(What:=Trim$(pvstrText), _
         LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    If Not objCell Is Nothing Then
       With ActiveDocument '// Hier Deine TextBox-Namen...
            .SelectContentControlsByTitle("TextBox2")(1).Range.Text = objCell.Offset(0, 1).Value
            .SelectContentControlsByTitle("TextBox3")(1).Range.Text = objCell.Offset(0, 2).Value
       End With
    Else
        Call MsgBox(Prompt:="Searched Data couldn't be found!", Buttons:=vbExclamation, Title:="Error")
    End If
 Else
    Call MsgBox(Prompt:="Application not installed!", Buttons:=vbExclamation, Title:="Error")
 End If
Sub_Exit:
 If Not objApp Is Nothing Then
    If lblnTMP Then
        Call objApp.Quit
        lblnTMP = False
    End If
 End If
 Set objCell = Nothing
 Set objWorkbook = Nothing
 Set objApp = Nothing
 If Err.Number <> 0 Then Call MsgBox(Prompt:="Fehler: " & _
    Err.Number & " " & Err.Description, _
    Buttons:=vbExclamation, Title:="Error")
End Sub

Private Function OffApp(ByVal pvstrApp As String, _
    Optional ByVal opvblnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(Class:=pvstrApp & ".Application")
    If Err.Number = 429 Then
        Call Err.Clear
        Set objApp = CreateObject(Class:=pvstrApp & ".Application")
        lblnTMP = True
        If opvblnVisible Then
            On Error Resume Next
            objApp.Visible = True
            Call Err.Clear
        End If
    End If
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Vier Erfolg erstmal...Gruß,