Re: Datum aus TextBox suche und Werte kopieren
25.05.2002 15:05:09
snurps
Hallo probieres es mal mit foldender Funktion
'***********************
'* was = der zu suchende Wert
'* ws = der Index des Tabellenblattes in dem gesucht werden soll
'* Ra = die Range in der gesucht werden soll in der Schreibweise "A1:A150"
'* spalte_suchen = True wenn Spalte gesucht wird, bei Zeile False (Normal ist False)
'* nurAnfang = True wenn nur der Anfang des Zelleninhaltes verglichen werden soll z.B. Zelleninhalt=Peter Müller und es soll nach Peter M gesucht werden
'* ist im Normalfall False
'*
'* wert_suchen gibt die gefunden Spalte oder Zeile als Zahl zurück
'*
'*
'*
'***********************
Function wert_suchen(was As String, ws, Ra, Optional spalte_suchen As Boolean, Optional nurAnfang As Boolean) As Double
letzter = 0
Dim gefunden As Boolean
gefunden = False
Sheets(1).Activate
With Sheets(ws).Range(Ra)
Set zelle = .Find(was, LookIn:=xlValues)
If Not zelle Is Nothing Then
ersteAdresse = zelle.Address
Do
advor = umw(zelle.Address(ReferenceStyle:=xlR1C1))
If spalte_suchen = True Then
advor = spalte(zelle.Address(ReferenceStyle:=xlR1C1))
End If
If nurAnfang = True Then
zellwert = Left(zelle, Len(was))
Else
zellwert = zelle
End If
If zellwert = was Then
gefunden = True
ergebnis = advor
Else
Set zelle = .FindNext(zelle)
End If
Loop While Not zelle Is Nothing And zelle.Address <> ersteAdresse And gefunden = False
End If
End With
If gefunden = True Then
wert_suchen = ergebnis
Else
wert_suchen = 0
End If
End Function
Function umw(ber) As Double
erstzen_text ber, "Z", "R"
erstzen_text ber, "S", "C"
a = InStr(1, ber, "C")
b = Mid(ber, 2, a - 2)
umw = b
End Function
Function erstzen_text(wert, ersetzen, durch) As String
zei1 = ersetzen
Do While InStr(wert, zei1) > 0
pos = InStr(wert, zei1)
re = Right(wert, Len(wert) - pos - Len(zei1) + 1)
li = Left(wert, pos - 1)
wert = li & durch & re
Loop
erstzen_text = wert
End Function
Function spalte(ber) As Double
erstzen_text ber, "Z", "R"
erstzen_text ber, "S", "C"
a = InStr(1, ber, "C")
If a > 0 Then
b = Right(ber, Len(ber) - (a))
spalte = b
Else
spalte = 0
End If
End Function
gruß
snurps