Ich habe zwei Tabellen

In einer (Liste1) etwa 2000 Einträge, in einer anderen (Liste2) etwa 5000 Einträge.

Ich muss durch eine Spalte Liste1 gehen und schauen, wo der Eintrag in Liste2 auftritt. Der Eintrag kann mehrfach auftreten. Immer wenn ich den Eintrag in Liste2 finde, muss ich in einer anderen Spalte einen Wert herausholen und den aufsummieren. In Summe also 2000*5000 Durchläufe

Ich habe eine Sub gebaut, die Funktioniert aber sooo langsam, das geht gar nicht.

Habt ihr eine bessere Idee?

Sub AListe_BListeA10()

Dim ELEMENT_A As String
Dim LR1, LR2, x, y, Counter1G, Counter10G, Counter1u10G As Integer
'Ermittele letzte Reihe

Application.ScreenUpdating = False
LR1 = Sheets("LISTE1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
LR2 = Sheets("LISTE2").UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Läuft durch die LISTE1 Liste, Spalte EndSZ
For x = 3 To LR1
    ELEMENT_A = Sheets("LISTE1").Range("C" + CStr(x))
    'Läuft durch die Liste2 und sucht wie oft ELEMENT_A auftritt
    For y = 2 To LR2
        If ELEMENT_A = Sheets("LISTE2").Range("N" + CStr(y)) Then
        'Füllt die beiden Counter
        Counter1u10G = Counter1u10G + 1 'ELEMENT_A 'Sheets("LISTE2").Range("N" + CStr(y))
            If Sheets("LISTE2").Range("L" + CStr(y)) = "1 Gigabit Ethernet" Then
                Counter1G = Counter1G + 1
                Else
                Counter10G = Counter10G + 1
            End If
        'Eintrag in LISTE1 Liste
        Sheets("LISTE1").Range("J" + CStr(x)) = Counter10G
        Sheets("LISTE1").Range("K" + CStr(x)) = Counter1G
        Sheets("LISTE1").Range("L" + CStr(x)) = Counter1u10G
        'Reset Counter
        Counter1G = 0
        Counter10G = 0
        Counter1u10G = 0
        End If
    Next y
Next x

Application.ScreenUpdating = True
End Sub