Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1672to1676
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
.Find-Funktion ähnliche Werte finden
05.02.2019 17:14:08
Tim
Hallo zusammen,
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

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 18:15:56
Nepumuk
Hallo Tim,
kannst du mal ein konkretes Beispiel für eine deiner Ähnlichkeiten geben?
Gruß
Nepumuk
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 18:25:47
Tim
Hi, ja klar:
Garage Nachbargebäude
Garage Nachbargebäude 1
Garage Nachbargebäude1
Garage Nachbargebäude_1
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 18:33:06
Daniel
Hi
Du kannst in Suchen/.Find die Jokerzeichen ? (Ein Zeichen) und * (beliebig viele Zeichen) verwenden und z.b. nach
Garage Nachbargeb*
Suchen.
Gruß Daniel
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 19:11:03
Nepumuk
Hallo Tim,
dann such mit dem Parameter: LookAt:=xlPart
Gruß
Nepumuk
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 19:49:12
Tim
Der Hinweis von Daniel war nicht schlecht, jedoch habe ich noch keine Möglichkeit gefunden eine If-Bedingung darüber zu legen.
Zudem habe ich mit LookAt:=xlPart gesucht.
=wenn Inhalt von Textbox ähnlich der Einträge in Datenbank, dann übernimm alle Daten die ähnlich sind und zeige sie mir in einer Listbox an.
Set rng = wksDaten.Columns(1).Find(What:=Veranstaltung, LookIn:=xlPart)
If rng größer als 1 Then MsgBox "ja"
Anzeige
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 20:44:08
onur
Hat nix mit deiner Frage direkt zu tun, aber:
Am Anfang jeder Sub pauschal
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

ist Quatsch, zumal dein Makro keine einzige Zelle verändert.
Einzelne Zeilen davon benutzt man bewusst, um bestimmten Problemen des Codes wie Bildschirmflackern, Endlosschleifen usw vorzubeugen bzw sie zu verhindern.
Das Selbe gilt für Errortrapping - sollte man nur benutzen, wenn man wirklich einen bestimmten Fehler erwartet und diesen bestimmten Fehler abfangen will.
Aber nicht pauschal wie Aspirin gegen alle möglichen Wehwehchen, zumal du dann nicht mal bemerkst, DASS irgendein Fehler auftauchte, geschweige denn Welcher (evtl sogar ein ganz Anderer als erwartet).
Anzeige
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 20:55:59
Tim
Hallo Onur,
da meine Kenntnisse mit Makros sehr bescheiden sind, ist das was der Code hergibt, einfach mit meinem Wissen und Google zusammengeschustert. Von daher bin ich über deine Aussagen eher dankbar als das ich sie als Kritik verstehe.
Ich passe das umgehend an. Dennoch möchte ich gern erreichen, dass mein Suchbegriff aus der Textbox auch ähnliche Einträge in der Datenbank in einer Listbox zeigt.
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 20:59:56
onur
Hi Tim,
War ja uch nicht als Kritik sondern als Tip für die Zukunft gemeint.
Dann solltest du besser mal die Datei (oder eine genauso aufgebaute Beispielsdatei) posten, damit mann nicht alles unnötigerweise auch noch nachbauen muss.
Gruß
Onur
Anzeige
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 21:11:42
Werner
Hallo Tim,
hier mal mein Versuch (ohne deine Datei zu kennen).
Kombination aus Find bzw. Autofilter
Option Explicit
Private Sub CommandButton1_Click()
Dim rng As Range, raListbox As Range, wksDaten As Worksheet
Dim loLetzte As Long, strSuchbegriff As String
Application.ScreenUpdating = False
'Blattname bitte an deine Verhältnisse anpassen
Set wksDaten = ThisWorkbook.Worksheets("Tabelle1")
'Listbox leeren
Me.ListBox1.Clear
With wksDaten
'Suchbegriff aus Textbox in Variable
strSuchbegriff = Me.TextBox1
'Suchbegriff nicht vorhanden Meldung
If WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 0 Then
MsgBox "Der Suchbegriff " & strSuchbegriff & " wurde nicht gefunden."
'Suchbegriff 1 x vorhanden Suchen mit Find und Ausgabe in Textbox2
ElseIf WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 1 Then
Set rng = wksDaten.Columns(1).Find(What:=strSuchbegriff, LookIn:=xlValues, lookat:= _
xlPart)
Me.TextBox2 = rng.Offset(0, 4)
'Suchbegriff mehrfach vorhanden
Else
'letzte belegte Zeile in Spalte A ermitteln
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
'Autofilter auf A1:E letzte belegte Zeile
.Range("A1:E" & loLetzte).AutoFilter
'Bereich nach Suchbegriff filtern
.Range("$A$1:$E$" & loLetzte).AutoFilter Field:=1, Criteria1:="*" & strSuchbegriff & "*" _
'Filterergebnis kopieren nach J1
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Columns(1).Copy .Cells(1, 10)
End With
'Autofilter raus
.AutoFilterMode = False
'letzte belegte Zeile in Spalte J ermitteln
loLetzte = .Cells(.Rows.Count, 10).End(xlUp).Row
'Bereich J1:J letzte belegte Zeile in Listbox einlesen
Me.ListBox1.List = .Range(.Cells(1, 10), .Cells(loLetzte, 10)).Value
'Spalte J leeren
.Columns(10).ClearContents
End If
End With
Set wksDaten = Nothing: Set rng = Nothing
End Sub
Gruß Werner
Anzeige
AW: .Find-Funktion ähnliche Werte finden
05.02.2019 21:40:59
Werner
Hallo Tim,
hier jetzt noch eine Version, bei der auch die "Hilfsspalte" in die das Filterergebnis zwischengespeichert wird, im Code ermittelt wird.
Zudem dann noch ein Makro für das Doppelklick_Event der Listbox. Doppelklick auf den richtigen Suchbegriff gibt dann den Wert aus .offset(, 4) in Textbox2 aus.
Option Explicit
Private Sub CommandButton1_Click()
Dim rng As Range, raListbox As Range, wksDaten As Worksheet
Dim loLetzte As Long, loSpalte As Long, strSuchbegriff As String
Application.ScreenUpdating = False
Set wksDaten = ThisWorkbook.Worksheets("Tabelle1")
Me.ListBox1.Clear
With wksDaten
strSuchbegriff = Me.TextBox1
If WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 0 Then
MsgBox "Der Suchbegriff " & strSuchbegriff & " wurde nicht gefunden."
ElseIf WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 1 Then
Set rng = wksDaten.Columns(1).Find(What:=strSuchbegriff, LookIn:=xlValues, lookat:= _
xlPart)
Me.TextBox2 = rng.Offset(0, 4)
Else
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range("A1:A" & loLetzte).AutoFilter
.Range("$A$1:$A$" & loLetzte).AutoFilter Field:=1, Criteria1:="*" & strSuchbegriff & "*" _
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy .Cells(1, loSpalte)
End With
.AutoFilterMode = False
loLetzte = .Cells(.Rows.Count, loSpalte).End(xlUp).Row
Me.ListBox1.List = .Range(.Cells(1, loSpalte), .Cells(loLetzte, loSpalte)).Value
.Columns(loSpalte).ClearContents
End If
End With
Set wksDaten = Nothing: Set rng = Nothing
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim strSuchbegriff As String, rng As Range, wksDaten As Worksheet
Application.ScreenUpdating = False
Set wksDaten = Worksheets("Tabelle1")
strSuchbegriff = Me.ListBox1
Me.ListBox1.Clear
With wksDaten
Set rng = wksDaten.Columns(1).Find(What:=strSuchbegriff, LookIn:=xlValues, lookat:=xlWhole)
Me.TextBox2 = rng.Offset(0, 4)
End With
Set rng = Nothing
End Sub
Gruß Werner
Anzeige
AW: .Find-Funktion ähnliche Werte finden
06.02.2019 13:06:40
Tim
Hallo Onur, Hallo Werner,
vielen Dank für die beiden Vorschläge, welche sehr gut funktionieren und meinen Vorstellungen entsprechen. Mit meinen Kenntnissen habe ich bisher nur Werners Vorschlag soweit anpassen können, dass er auf eine externe Quelle zugreifen kann, wobei mir die Code-Länge von Onur besser gefällt.
Hier mal meine Anpassung:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim wksDaten As Worksheet, rng As Range, raListbox As Range
Dim wkbDaten As Workbook
Dim loLetzte As Long, loSpalte As Long, strSuchbegriff As String
Application.ScreenUpdating = False
On Error GoTo FEHLER
Workbooks.Open "C:\Desktop\Testprogramm\Test.xlsx"
Set wkbDaten = Workbooks("Test.xlsx")
Set wksDaten = wkbDaten.Sheets("Tabelle1")
Me.ListBox1.Clear
With wksDaten
strSuchbegriff = Me.TextBox1
If WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 0 Then
MsgBox "Der Suchbegriff " & strSuchbegriff & " wurde nicht gefunden."
ElseIf WorksheetFunction.CountIf(.Columns(1), "*" & strSuchbegriff & "*") = 1 Then
Set rng = wksDaten.Columns(1).Find(What:=strSuchbegriff, LookIn:=xlValues, lookat:= _
xlPart)
Me.TextBox2 = rng.Offset(0, 4)
Else
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range("A1:A" & loLetzte).AutoFilter
.Range("$A$1:$A$" & loLetzte).AutoFilter Field:=1, Criteria1:="*" & strSuchbegriff & "*" _
_
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy .Cells(1, loSpalte)
End With
.AutoFilterMode = False
loLetzte = .Cells(.Rows.Count, loSpalte).End(xlUp).Row
Me.ListBox1.List = .Range(.Cells(1, loSpalte), .Cells(loLetzte, loSpalte)).Value
.Columns(loSpalte).ClearContents
End If
End With
Set wksDaten = Nothing: Set rng = Nothing
wkbDaten.Close savechanges:=False
FEHLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim strSuchbegriff As String, rng As Range, wksDaten As Worksheet
Dim wkbDaten As Workbook
On Error GoTo FEHLER
Application.ScreenUpdating = False
Workbooks.Open "C:\Desktop\Testprogramm\Test.xlsx"
Set wkbDaten = Workbooks("Test.xlsx")
Set wksDaten = wkbDaten.Sheets("Tabelle1")
strSuchbegriff = Me.ListBox1
Me.ListBox1.Clear
With wksDaten
Set rng = wksDaten.Columns(1).Find(What:=strSuchbegriff, LookIn:=xlValues, lookat:=xlWhole)
Me.TextBox2 = rng.Offset(0, 3)
End With
Set rng = Nothing
wkbDaten.Close savechanges:=False
FEHLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Anzeige

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige