Private
Sub
CommandButton1_Click()
Dim
Meldung
As
Byte
, Pos
As
Byte
Dim
Schleife
As
Byte
, y
As
Byte
Dim
Begriff, Suchen()
As
Variant
Dim
Bereich
As
Range
Dim
n%, x%, xZelle%, yZelle%
Dim
xTabelle$(), Adresse$(), Text$
Begriff = InputBox _
(
"Bitte den zu suchenden Begriff eingeben. Sollen 2 Werte"
& vbCrLf & _
"gleichzeitig gesucht werden, dann mit Zeichen + "
& vbCrLf & _
"voneinander trennen (z.B.: Summe+die)."
& vbCrLf & vbCrLf & _
"ENTER ohne Wert = Abbruch"
,
"S U C H M O D U S"
)
If
Begriff =
""
Then
Exit
Sub
Pos = InStr(Begriff,
"+"
)
If
Pos
Then
ReDim
Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim
Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End
If
Application.ScreenUpdating =
False
x = 1
For
y = 1
To
Schleife
For
n = 1
To
Sheets.Count
Set
Bereich = Worksheets(n).UsedRange
With
Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End
With
With
Sheets(n).Range(Bereich.Address)
Set
c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
If
Not
c
Is
Nothing
Then
ErsteAdresse = c.Address
Do
ReDim
Preserve
Adresse(x):
ReDim
Preserve
xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=
False
, ColumnAbsolute:=
False
)
Set
c = .FindNext(c)
x = x + 1
Loop
While
Not
c
Is
Nothing
And
c.Address <> ErsteAdresse
End
If
End
With
Next
n
Next
y
Application.ScreenUpdating =
True
Select
Case
x
Case
1
Meldung = MsgBox(
"Es wurde kein übereinstimmender Wert gefunden"
, _
vbOKOnly,
"G E F U N D E N E W E R T E"
)
Exit
Sub
Case
Else
Meldung = MsgBox(
"Es wurden "
& (x - 1) &
" Übereinstimmungen gefunden."
, _
vbOKOnly,
"G E F U N D E N E W E R T E"
)
On
Error
Resume
Next
With
ActiveSheet
.Name =
"Startseite"
.[I5] =
"Suchergebnis"
For
n = 1
To
x - 1
.Cells(n + 7, 9) = xTabelle(n)
.Cells(n + 7, 10) = Begriff
Next
n
End
With
End
Select
End
Sub