Suche ändern

Private Sub CommandButton1_Click()
'Suche Starten
Dim xSuche, xAdresse, xErste As String
Dim SpFarbe As Long, sFarbe As String
Dim sFarbSuch As String, sGroesseSuch As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim iCounter, iRowU As Integer
ListBox1.Clear
xSuche = TextBox1.Value
If xSuche = "" Then
MsgBox "Bitte erst einen Suchbegriff eingeben!", vbExclamation, "Achtung!"
Exit Sub
End If
If ComboBox1.Value = "" And CheckBox2.Value = False Then
MsgBox "Bitte geben Sie ein, wo der Begriff gesucht werden soll!", vbExclamation, "Achtung!" _
Exit Sub
End If
sFarbe = Me.ListBox_Farbe.Value
For iCounter = 1 To ThisWorkbook.Sheets.Count 'Gesamtanzahl der Sheets
If CheckBox2.Value = True Or Worksheets(iCounter).Name = ComboBox1.Value Then
'Spalten- und Farbwerte für Suche in den Blättern setzen
Select Case Worksheets(iCounter).Name
Case "Tabelle1"
GoTo Weiter01 'Tabelle 1 nicht durchsuchen
Case "Tabelle2", "Tabelle3", "Tabelle4" 'Tabelle4 ergänzt
If sFarbe  "(Alle)" Then SpFarbe = 2 Else SpFarbe = 99
sFarbSuch = sFarbe
sGroesseSuch = Me.ListBox_Groesse.List(0, 0) '(Alle) - keine Vorgabe für Größe  _
erforderlich
Case "Produkt 1", "Produkt 2", Tabelle2(4)
SpFarbe = 99
sFarbSuch = "x"
Select Case sFarbe
Case "":       SpFarbe = 99
Case "blau":   SpFarbe = 4 'Ziffer = Spalte
Case "gelb":   SpFarbe = 5
Case "grün":   SpFarbe = 6
Case "rot":    SpFarbe = 7
Case "weiß":   SpFarbe = 8
Case "ws":     SpFarbe = 9
Case "(Alle)": SpFarbe = 99
Case Else
MsgBox "Case für Farbe """ & sFarbe & """ fehlt in Programmierung"
SpFarbe = 99
End Select
sGroesseSuch = "x"
'Spalten mit den verschiedenen Größen
arrSpGroesse(0) = 99 '(Alle)
arrSpGroesse(1) = 10 'Größe 1
arrSpGroesse(2) = 11 'Größe 2
arrSpGroesse(3) = 12 'Größe 3
arrSpGroesse(4) = 13 'Größe 4
arrSpGroesse(5) = 14 'Größe 5
Case Else
MsgBox "Case für Tabelle """ & Worksheets(iCounter).Name & """ fehlt in  _
Programmierung"
GoTo Weiter01
End Select
Set rng = Worksheets(iCounter).UsedRange.Find _
(xSuche, lookat:=Suchart, LookIn:=xlValues)
If Not rng Is Nothing Then
With Worksheets(iCounter)
xErste = rng.Address(False, False)
Do Until xAdresse = xErste
If rng.Row > 1 And (SpFarbe = 99 Or .Cells(rng.Row, SpFarbe) = sFarbSuch) _
And fncCheckGroesse(rng, sGroesseSuch) Then
y = True
ReDim Preserve arr(0 To 6, 0 To iRowU)
arr(0, iRowU) = .Name
arr(1, iRowU) = rng.Address(False, False)
Select Case .Name
Case "Tabelle1", "Tabelle2"
arr(2, iRowU) = .Cells(rng.Row, 1)
arr(3, iRowU) = .Cells(rng.Row, 2)
arr(4, iRowU) = .Cells(rng.Row, 3)
arr(5, iRowU) = .Cells(rng.Row, 4)
arr(6, iRowU) = .Cells(rng.Row, 5)
Case "Produkt 1", "Produkt 2"
arr(2, iRowU) = .Cells(rng.Row, 2) 'Produkt
arr(3, iRowU) = sFarbe
arr(4, iRowU) = .Cells(rng.Row, 15) 'VE
arr(5, iRowU) = .Cells(rng.Row, 3) 'Art.-Nr.
arr(6, iRowU) = .Cells(rng.Row, 1) 'Hersteller
End Select
iRowU = iRowU + 1
End If
Set rng = .UsedRange.FindNext( _
after:=IIf(rng.Row + 1 > .UsedRange.Rows.Count, .Cells(1, 1), _
.Cells(rng.Row, .UsedRange.Columns.Count)))
xAdresse = rng.Address(False, False)
Loop
xAdresse = ""
xErste = ""
End With
End If
End If
Weiter01:
Next iCounter
If y = False Then
MsgBox "Der Suchbegriff wurde nicht gefunden!"
Else
ListBox1.Column = arr
End If
End Sub