Option Explicit

Sub Test()
  
  Dim rngName As Excel.Range
  Dim dicData As Object
  
  Set dicData = CreateObject("Scripting.Dictionary")
  
'Daten sammeln
  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
  
'Ausgabe
  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