Werte UserForm in Array übernehmen

Sub Suchen_und_Fundstellen_auflisten_mehrere_Tabellen()
Dim Meldung As Variant, strWort() As Variant
Dim Bereich As Range, Rng As Range
Dim WS As Worksheet
Dim y As Double, IntI As Double, n As Double
Dim arrFind()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strWort() = Array("Morgen", "Heute", "Gestern", "Test")
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
n = 0
For y = 1 To Sheets.Count
If Sheets(y).Name  "Auswahltabelle" Then
' Bereich festlegen
Set Bereich = Worksheets(y).UsedRange
For Each Rng In Bereich
For IntI = 0 To 3 'Anzahl Array = 4 (0,1,2,3)
If InStr(Rng, strWort(IntI)) Then
n = n + 1
ReDim Preserve arrFind(1 To 2, 1 To n)
arrFind(1, n) = Sheets(y).Name
arrFind(2, n) = Rng.Address(RowAbsolute:=False, ColumnAbsolute:=False)
End If
Next
Next
End If
Next
Select Case n
Case 1
Meldung = MsgBox("Es wurde leider nichts gefunden", _
vbOKOnly, "   Gefundene Werte")
Exit Sub
Case Else
Meldung = MsgBox(n & " Übereinstimmungen gefunden.", _
vbOKOnly, "   Gefundene Werte")
' Tabelle einfügen
For Each WS In Worksheets
If WS.Name = "Auswahltabelle" Then
WS.Delete
End If
Next
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
.Name = "Auswahltabelle"
.[A1] = "Suchergebnis"
.Range(.Cells(2, 1), .Cells(1 + n, 2)).Select
.Range(.Cells(2, 1), .Cells(1 + n, 2)) = Application.Transpose(arrFind)
.Cells.EntireColumn.AutoFit
.Cells(1, 1).Select
End With
End Select
Sheets(y).Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub