Ich habe das aus einem anderen Code wo ich bereits eine Suche habe laufenlassen mit weniger Einträgen.

Dort hatte es bereits lange gedauert.

Mit so vielen will ich es mir gar nicht erst ausmalen, wie lange er da braucht.

da ich gerade an der Übergabe einer Variablen aus einer Userform hänge, habe ich den Code noch nicht getestet.

Dies soll auch nur grob zeigen in welche Richtung mein Code laufen soll. Der der zu langsam ist.

Ich habe jetzt etwas gelesen, das man mit einem Array arbeiten soll, da die Werte dabei in den Arbeitsspeicher geschrieben werden und die Abarbeitung deutlich schneller sein soll.

Die Variablen habe ich noch nicht abgeändert. Ich habe aber versucht die Erklärungen dazu zu kommentieren. ich hoffe es Verwirrt nicht zu sehr.

Solltest du in dem Code Fehler finden, kannst du mir bitte sofort bescheid sagen, dan ändere ich es gleich ab.

'Suche nach Teilstring
  Dim rFinde1 As Range, rSuche1 As Range         ' das ist eine einfache Variablendeklaration
  Dim strFirst1 As String
  Dim lngReihe1 As Long, lngLetzte1, lngLetzte2 As Long
  Dim I1 As Integer

With Workbook (QName) 'Name des ZielWorkbook aus dem die Werte zum Suchen kommen (In meinem Text ZWB)
  With Sheets(Ort31)  'Name des ZielWorksheet (Zielsheet)

  lngLetzte1 = IIf(IsEmpty(.Cells(Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) ' letzte volle Zeile in Sheet Zielsheet ermitteln, da stehen die Suchwerte in den Spalten von Spalte B
  End With

With Workbook (Suchliste) ' QuellWorkbook mit allen EQ (QWB)
  With Sheets(Suchsheet)  '(Quellsheet)mit allen EQ
  lngLetzte2 = IIf(IsEmpty(.Cells(Rows.Count, 1)), .Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) ' letzte volle Zeile in Sheet Quellsheet ermitteln, da stehen die Suchwerte in den Spalten von Spalte A
  End With

  Set rFinde1 = Sheets(Suchliste & Suchsheet).Range("A2:A" & LngLetzte2) ' In Spalte A Sheet Suchsheet soll gesucht werden, da stehen die zu vergleichenden Werte
  With Sheets(QName & "\" &  Ort 31)
    For I1 = 1 To lngLetzte1 ' Suchschleife, da ja mehr als nur ein Suchwert
       Set rSuche1 = rFinde1.Find(what:=.Cells(I1, 2), lookat:=xlWhole) ' .cells.. ist der jeweilige Suchwert
          If Not rSuche1 Is Nothing Then ' wenn, was gefunden wurde
             strFirst1 = rSuche1.Address ' merke dir die erste gefundene Zelle (weil können ja mehr sein)
             Do ' weiter Schleife, um die anderen gleichen zu finden
               lngReihe1 = rSuche1.Row ' wir merken uns die Zeile wo in Ort31 der Suchstring steht
               
              
              Sheets(Ort31).Range("A" & lngReihe1) = "Aktiv" 'Ich glaube das ist der Richtige String
              'Sheets(ort31).Range("A" & I1) = "Aktiv"       ' Der hier ist die Alternative, falls der oben nicht richtig ist.        
               
               Set rSuche1 = rFinde1.FindNext(rSuche1) ' wir suchen den nächsten, gleichen Suchstring
             Loop While Not rSuche1 Is Nothing And rSuche1.Address <> strFirst1 'das tun wir solange, bis wir wieder bei der ersten Adresse sind und somit alle gefunden wurden.
          End If
      Next I1
  End With

Danke