Makro Reiterverweismatrix

Hallo liebe Excler!
Ich habe ein Makro erstellt, welches mir in einer Matrix die Anzahl der Verweise von Sheet zu Sheet auflisten soll.
Dazu werden 2 Sheets angelegt: (1) SheetMatrixOverview & (2) SheetSearchList
Prinzip:
1. A: Reiternamen auflisten
2. Loop ersten Suchbegriff (reiternamen) aus A auswählen und die komplette Mappe danach durchsuchen, bei Treffern:
3. C: Zelle eintragen
4. D: Reiter (in dem Verweis gefunden wurde) eintragen
5. nächster Suchbegriff aus A
Problem: Ich möchte das Makro effizienter und robuster machen, indem die Mappe nur einmal nach allen Suchbegriffen gleichzeitig durchsucht wird (Bei 100 Reitern mit Werten wird das Makro extrem langsam -> ExcelCrash)
Ich habe mich dem Problem versucht via Array oder ähnlichem anzunähern und komme nicht weiter.
und später noch:
6. via indirect Wert auslesen und einige andere Formeln
Die Originalexcel kann ich leider nicht hochladen, da sie extrem groß ist.
Hier der VBA-Code:

Sub Hirn()
Dim strFilename As String
Dim wkbMappe As Workbook 'neue Mappe
Dim AmountSheets As Long 'Reiteranzahl auslesen
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
WS.Visible = xlSheetVisible
Next WS
Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
ChDrive "c:\"
ChDir "\temp\"
strFilename = ("SheetLinksMatrixOverview" & Format(Date, "yyyymmdd") & ".xlsx")
Application.Dialogs(xlDialogSaveAs).Show (strFilename)
strFilename = ActiveWorkbook.Name
'SheetMatrixOverview
For Each WS In Worksheets
If WS.Name = "SheetMatrixOverview" Then WS.Delete
Next WS
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "SheetMatrixOverview"
'SheetSearchList
For Each WS In Worksheets
If WS.Name = "SheetSearchList" Then WS.Delete
Next WS
Worksheets.Add after:=Worksheets(1)
ActiveSheet.Name = "SheetSearchList"
' Suchlegende erstellen mit Umbennenung in Folgespalte
Sheets("SheetSearchList").Activate
For AmountSheets = 3 To Workbooks(strFilename).Worksheets.Count '5 durch 2 ersetzen
Cells(1, 1).Value = "Suchbegriffe:"
Cells(AmountSheets - 1, 1).Value = "'" & Workbooks(strFilename).Sheets(AmountSheets). _
Name & "'!"
Next AmountSheets
' Begin Suchschleife nach Begriffen in Spalte B ab B2
Dim X As Integer
X = 2
Do Until IsEmpty(Worksheets("SheetSearchList").Cells(X, 1))
B = Worksheets("SheetSearchList").Cells(X, 1)
Dim strFind As String
Dim rng As range
Dim strAddress As String
Dim Z As Integer
strFind = B
If strFind = "" Then MsgBox ("idiot") ' <- höhö
For Each WS In Worksheets
Set rng = WS.Cells.Find(strFind)
If Not rng Is Nothing Then
strAddress = rng.Address
Do
On Error GoTo Error
Application.Goto rng
With Worksheets("SheetSearchList")
Z = 1
Do Until IsEmpty(Worksheets("SheetSearchList").Cells(Z + 1, 3))
Z = Z + 1
Loop
Z = Z + 1
Worksheets("SheetSearchList").Cells(Z, 3) = rng.Address
Worksheets("SheetSearchList").Cells(Z, 4) = rng.Worksheet.Name
End With
Set rng = WS.Cells.FindNext(after:=ActiveCell)
Loop While rng.Address <> strAddress
End If
Next WS
'Application.Goto Worksheets(1).Range("A1")    Später
Set rng = Nothing
X = X + 1
Loop
Sheets("SheetSearchList").Activate
'2te Tabelle
Worksheets("SheetSearchList").Cells(1, 3) = "Cell:"
Worksheets("SheetSearchList").Cells(1, 4) = "Location:"
Worksheets("SheetSearchList").Cells(1, 5) = "Value:"
Worksheets("SheetSearchList").Cells(2, 5).FormulaLocal = "=IF(AND(C2=""""; _
D2="""");"""";INDIRECT(""'""&D2&""'!""&C2))"
'Für die dritte Tabelle
Dim AmountSearchedSheets As Long
AmountSearchedSheets = range(range("A1"), range("A1").End(xlDown)).Rows. _
Count
'dritte Tabelle
Worksheets("SheetSearchList").Cells(1, 7) = "Auf wen wird verlinkt:"
Worksheets("SheetSearchList").Cells(2, 7).FormulaLocal = "=IF(AND(C2=""""; _
D2="""");"""";IF(ISNUMBER(MATCH(E2;$A$2:$A$" & AmountSearchedSheets & ";0));E2;G1))"
Worksheets("SheetSearchList").Cells(2, 8).FormulaLocal = "=IF(G2="""";""""; _
LEFT(G2;LEN(G2)-2))"
'Fürs Runterziehen
Dim AmountValues As Long
AmountValues = range(range("C2"), range("C2").End(xlDown)).Rows.Count + 1
'Runterziehen
range("E2:H2").Select
Selection.Copy
range("E2:H" & AmountValues + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Matrixformel
Sheets("SheetMatrixOverview").Activate
For AmountSheets = 3 To Workbooks(strFilename).Worksheets.Count
Cells(AmountSheets - 1, 1).Value = Workbooks(strFilename).Sheets( _
AmountSheets).Name
Cells(1, 1).Value = "Matrix:"
Cells(1, AmountSheets - 1).Value = Workbooks(strFilename).Sheets( _
AmountSheets).Name
Next AmountSheets
Worksheets("SheetMatrixOverview").Cells(2, 2).FormulaLocal = "=COUNTIFS( _
SheetSearchList!$D$2:$D$" & AmountValues & ";SheetMatrixOverview!$A2;SheetSearchList!$H$2:$H$" & AmountValues & ";SheetMatrixOverview!B$1)"
'Letzten Spaltenbuchstaben
Dim strAdd As String
Dim strLetter As String
strAdd = Mid((Cells(1, AmountSearchedSheets).Address), 2, Len(Cells(1,  _
AmountSearchedSheets).Address) - 3)
'Matrix runterziehen
range("B2").Select
Selection.Copy
range("B2:" & strAdd & AmountSearchedSheets).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
Exit Sub
Error:
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung  _
einschalten falls ein Fehler ausgegeben wird
MsgBox ("Error 404 - Page not Found")
End Sub