Option Explicit
Sub Test()
Dim rngName As Excel.Range
Dim dicData As Object
Set dicData = CreateObject("Scripting.Dictionary")
With Worksheets("Tabelle1")
For Each rngName In .Range("C2", .Cells(.Rows.Count, "C").End(xlUp))
If dicData.Exists(rngName.Value) = False Then
Call dicData.Add(Key:=rngName.Value, Item:=CreateObject("Scripting.Dictionary"))
End If
Dim rngManufacturer As Excel.Range
Dim rngDevices As Excel.Range
Dim rngDevice As Excel.Range
Set rngManufacturer = rngName.Offset(0, -1)
With Worksheets("Tabelle2")
Set rngDevice = .Range("A1", .Range("A1").End(xlToRight)) _
.Find(rngManufacturer.Value, , xlValues, xlWhole, xlByColumns, , False)
If rngDevice Is Nothing Then
GoTo Continue_ForEach_Name
End If
Set rngDevices = .Range(rngDevice.Offset(1), rngDevice.End(xlDown))
End With
For Each rngDevice In rngDevices
dicData(rngName.Value)(rngDevice.Value) = dicData(rngName.Value)(rngDevice.Value) + 1
Next
Continue_ForEach_Name:
Next
End With
Dim rngOutput As Excel.Range
Dim vntName As Variant
Dim vntDevice As Variant
Set rngOutput = Worksheets("Tabelle3").Range("A1:C1")
rngOutput.Value = Array("Name", "Was ist Doppelt", "Anzahl Doppelt")
For Each vntName In dicData
For Each vntDevice In dicData(vntName)
If dicData(vntName)(vntDevice) > 1 Then
Set rngOutput = rngOutput.Offset(1)
rngOutput.Value = Array(vntName, vntDevice, dicData(vntName)(vntDevice))
End If
Next
Next
rngOutput.EntireColumn.AutoFit
End Sub