01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48 |
|
Sub Suche()
Dim rBereich As Range
Dim sIchsuche As String, sErsteAdresse As String
Dim sBer As String, sArr() As String
Dim WSh As Worksheet, iZeile As Long, i As Long, iGefunden As Long
Dim bCheck As Boolean
sIchsuche = InputBox("Was brauchst du?", "Ersatzteilsuche")
If StrPtr(sIchsuche) = 0 Then Exit Sub
If sIchsuche = "" Then
MsgBox "Junge nix kon ma ned findn!", vbCritical, "Suche"
Exit Sub
End If
Set WSh = Worksheets("Tabelle1")
WSh.Range("A10:I1000").Clear
With Worksheets("Tabelle2").Range("A:I")
sArr = Split(sIchsuche)
Set rBereich = .Find(sArr(0), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not rBereich Is Nothing Then
sErsteAdresse = rBereich.Address
Do
iZeile = WSh.Cells(Rows.Count, "A").End(xlUp).Row + 1
If iZeile < 10 Then iZeile = 10
bCheck = True
If UBound(sArr) > 0 Then
For i = 1 To UBound(sArr)
On Error Resume Next
sBer = rBereich.Row & ":" & rBereich.Row
If Application.WorksheetFunction.Match(sArr(i) & "*", .Range(sBer), 0) = 0 Then
bCheck = False: Exit For
End If
Next i
On Error GoTo 0
End If
If bCheck Then
rBereich.EntireRow.Copy WSh.Cells(iZeile, "A").EntireRow
End If
Set rBereich = .FindNext(rBereich)
Loop While Not rBereich Is Nothing And rBereich.Address <> sErsteAdresse
Else
MsgBox "Der Suchbegriff '" & sIchsuche & "' konnte nicht gefunden werden!", vbCritical, "Suche"
End If
End With
End Sub
|