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
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
For Each rngCheck In rng.Cells
If IsEmpty(rngCheck) Then
Exit For
End If
Next
If Not rngCheck Is Nothing Then
rngCheck.value = value
End If
End If
End Sub