.Find-Funktion ähnliche Werte finden
05.02.2019 17:14:08
Tim
ich habe ein Makro mit dem ich eine Datenbank öffne, einen Wert darin via TextBox suche und mir "wenn gefunden", die dazugehörigen Werte zurückgeben lasse. Das funktioniert perfekt. Jetzt habe ich das Problem, dass ich nur eindeutige Werte finden kann. Sollten ähnliche Begriffe in der Datenbank sein, dann würde ich mir diese gern in eine Listbox geben lassen, um den richtigen Eintrag auswählen zu können.
Ziel ist es bei einem eindeutigen Wert die Daten zu übernehmen (funktioniert) und bei Mehrdeutigkeit alle gefunden Werte in eine Listbox geben.
Hintergrund ist, dass es einzelne Einträge in der Datenbank gibt die ähnlich lauten ohne, das Derjenige, der den Wert sucht, die genaue Bezeichnung kennt.
Wie muss man die .Find-Funktion dahingehend anpassen damit genau das funktioniert!?
Meine ersten Versuche habe ich mit CountIfs probiert jedoch entspricht das nicht ganz meiner Vorstellung.
Sub Datenbank_durchsuchen()
Dim wksDaten As Worksheet
Dim wkbDaten As Workbook
Dim rng As Range
On Error GoTo FEHLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Workbooks.Open "C:\Users\Test"
Set wkbDaten = Workbooks("Einträge.xlsx")
Set wksDaten = wkbDaten.Sheets("Datenbank")
If UserForm1.TextBox1 "" Then
Set rng = wksDaten.Columns(1).Find(What:=UserForm1.TextBox1, LookIn:=xlValues)
If WorksheetFunction.CountIfs(Worksheets("Datenbank").Columns(1), UserForm1.TextBox1) > 1 Then ' _
prüft ob der Suchwert mehr als einmal in der Liste auftaucht, wenn ja dann öffnet er die Userform2 und zeigt die Details an
MsgBox "Ja"
End If
If Not rng Is Nothing Then
UserForm1.TextBox2 = rng.Offset(0, 4)
End If
End If
wkbDaten.Close
FEHLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub