Aus dem Fundus im Forum habe ich folgenden Code zusammengestellt, der prima funktioniert:
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
Nun sollte ich aber die Suchbegriffe Variabel gestallten, indem ich in einer UserForm max 10 Suchbegriffe zur Auswahl vorgebe. Der User soll die gewünschten Suchbegriffe (mehrere) anklicken können und anschliessend sollten die angewählten Begriffe in den Array zum Suchen übernommen werden. Wie muss ich meinen Code ergänzen?Danke und Gruss
Gregor