Hallo,

dieser Code sollte das gewünschte Vorhaben umsetzen:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wbk As Workbook
    Dim rngNew As Range
    Dim strFilename As String
    strFilename = ThisWorkbook.Path & "\Übersicht.xlsx"
    Set wbk = GetWorkbook(strFilename)
    If wbk Is Nothing Then
        Set wbk = Application.Workbooks.Open(strFilename)
        ThisWorkbook.Activate
    End If
     For Each rngNew In Target.Cells
        If rngNew.Row >= 4 Then
            ' Existiert der gesuchte Eintrag in einer anderen Zelle?
            If WorksheetFunction.CountIf(Target.Worksheet.Range("A4:A1048576"), rngNew.value) = 1 Then
                FillOverviewWorkbook wbk, rngNew.value
            End If
        End If
    Next
End Sub

Private Function GetWorkbook(sFilename As String) As Workbook
    Dim wbk As Workbook
    For Each wbk In Application.Workbooks
        If wbk.FullName = sFilename Then
            Set GetWorkbook = wbk
            Exit For
        End If
    Next
End Function

Private Sub FillOverviewWorkbook(wbk As Workbook, value As String)
    Dim rng As Range
    Dim rngCheck As Range
    Dim wsh As Worksheet
    Set wsh = wbk.Worksheets(1)
    Set rng = wsh.Range("A10:A1048576")
    If rng.Find(what:=value) Is Nothing Then
        ' Freie Zelle finden
        For Each rngCheck In rng.Cells
            If IsEmpty(rngCheck) Then
                Exit For
            End If
        Next
        ' Neuen Eintrag anlegen
        If Not rngCheck Is Nothing Then
            rngCheck.value = value
        End If
    End If
End Sub

Vorausetzung: Die Arbeitsmappen "Übersicht.xlsx" und "Kursteilnehmer.xlsm" müssen im gleichen Verzeichnis gespeichert sein.

Beide Muster-Arbeitsmappen können hier heruntergeladen werden.

LG, BigBen