Hallo Joshuah! Den folgenden COde bei der Userform in den Codeteil packen.Button 1 ist dabei der zum absenden = eintragen. Button 2 der Abbruch und dann noch die Listbox. Beim Code nicht wundern. Ich lasse mal im Code deine Listbox auf zweispaltig einstellen und blende die zweite spalte aus. Dort stehen die Werte drinen die übernomen werden sollen. Spare mir dadurch die woandershin zu übertragen. Musst nur mal schauen, ob dein Text richtig reinpasst. Habe mal 8 cm für die Spalte 1eingstellt - kannst du auch noch erhöhen. Ich gehe dann auch mal auf einzelne FEhlerquellen ein und prüfe das. LEdilgich die Tabelle prüfe ich nicht,. DIe soll in der Quelldatei vorhanden sein und auch überall gleich viele Spalten haben. DU musst nur bei pfad mal deine DAtein eintragen. Also den Pfad mit NAmen. Dann sollte es passen. Gruß

Private Sub CommandButton1_Click()
'einrtagen
If Me.ListBox1.ListIndex = -1 Then
    MsgBox " Es wurde nichts ausgewählt!"
    Unload UserForm1
    Exit Sub
Else
    If Me.ListBox1.List(Me.ListBox1.ListIndex, 0) = "Die Daten konnten nicht gelesen werden!" Then
    MsgBox "Der Übertrag schlug fehl!"
    Unload UserForm1
    End If
    Exit Sub
End If
ActiveDocument.Bookmarks("Text").Range.Text = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
Unload UserForm1
End Sub

Private Sub CommandButton2_Click()
'Schaltfläche abbrechen
Unload UserForm1
End Sub

Private Sub UserForm_Initialize()
Dim wert
Dim wert2
Dim Doc As Document
Dim pfad As String
Dim auf
Dim i As Long

Application.ScreenUpdating = False

pfad = "C:\Users\ich\Desktop\Programmieung\quelle.doc"
auf = Dir(pfad)

If auf = "" Then
    Me.ListBox1.AddItem ("Die Daten konnten nicht gelesen werden!")
    Exit Sub
End If

Me.ListBox1.ColumnCount = 2
Me.ListBox1.ColumnWidths = "8 cm;0 "

Set Doc = Documents.Open(pfad)

For i = 1 To Doc.Tables(1).Columns(2).Cells.Count - 1
    wert = Doc.Tables(1).Columns(2).Cells(i).Range
    wert = Left(wert, Len(wert) - 2)
    wert2 = Doc.Tables(1).Columns(3).Cells(i).Range
    wert2 = Left(wert2, Len(wert2) - 2)
    
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 1, 0) = wert
    Me.ListBox1.List(i - 1, 1) = wert2

Next i
Doc.Close SaveChanges:=False

Application.ScreenUpdating = True

End Sub