Re: mehrere Werte gleichzeitig suchen
09.01.2003 01:27:38
L.Vira
''written by L.Vira for softsmith, mailto:softsmith@web.de
''Zur freien Verwendung ohne jegliche Garantie!
''-----------------------------------------------------------------
''Voraussetzungen:
''Folgende Elemente müssen vorhanden sein:
''Mindestens eine Tabelle mit dem Namen "Daten"
''-----------------------------------------------------------------
''UserForm1 mit den Steuerelementen:
''Commandbutton mit dem Namen "cmdOK"
''Textbox mit dem Namen "txtDate"
''Textbox mit dem Namen "txtWort"
''Alle Namen natürlich ohne Anführungszeichen!
''-----------------------------------------------------------------
''Das Ergebnis der Suche wird im Blatt "Daten" protokolliert.
''-----------------------------------------------------------------
''Beim Start wird das aktuelle Datum vogeschlagen.
''Das Datum kann in der Form 9.1.3 eingegeben werden.
''-----------------------------------------------------------------
Option Explicit
Private Sub cmdOK_Click()
If Not IsDate(txtDate) Then
MsgBox "Kein gültiges Datum!"
txtDate = ""
txtDate.SetFocus
Exit Sub
End If
If txtWort = "" Then
MsgBox "Suchbegriff eingeben!"
txtWort.SetFocus
Exit Sub
End If
Call suchen
End Sub
Private Sub UserForm_Initialize()
txtDate = Date
End Sub
Sub suchen()
Dim Z As Range, x As Long, Sh As Integer
Dim aSh As Worksheet, Dat As Worksheet
Set Dat = Sheets("Daten")
Dat.Cells.ClearFor Sh = 1 To Sheets.Count
Set aSh = Sheets(Sh)
If aSh.Name <> "Daten" Then
x = x + 1
Dat.Cells(x, 1) = aSh.Name
If aSh.[h2] = CDate(txtDate) Then
Dat.Cells(x, 2) = "Datum gefunden"
Else
Dat.Cells(x, 2) = "Datum nicht gefunden"
End If
With aSh.[c3:c55]
Set Z = .Find(txtWort, LookIn:=xlValues, lookat:=xlWhole)
If Not Z Is Nothing Then
On Error Resume Next
Dat.Cells(x, 3) = Z.Address(False, False)
Dat.Cells(x, 4) = Z.Value
Else
Dat.Cells(x, 3) = "Text nicht gefunden"
Dat.Cells(x, 4) = ""
End If
End With
End If
Next
Dat.Columns.AutoFit
Dat.Select
Unload Me
If x = 0 Then
ende:
MsgBox "Nix derartiges gefunden! ", 64, "stelle fest..."
End If
Set Z = Nothing
Set aSh = Nothing
Set Dat = Nothing
End Sub