Abkürzungsverzeichnis Userform Suche Teilabfrage

[newbie69]

Hallo liebe Excel-Experten,

habe da eine Frage zu meinem Abkürzungsverzeichnis. Ich habe einen Code gefunden, der genau das wieder spiegelt, was ich suche, eine simple Suchabfrage einer Abkürzung und das Ergebnis wird in einer 2-spaltigen  Listbox ausgegeben.  (Abkürzung, Erklärung)

Jetzt habe ich folgendes Problem, wenn ich in meiner Suchmaske aber einen Teilbegriff eingebe, möchte ich, dass alle Wörter, die diesen Begriff beinhalten dargestellt werden. z.B.

SpalteA:
(a)Sim
Abc
AAC
ACA
..
SIM

Sucheingabe: SIM
Ergebnis sollte sein: (a)Sim, SIM
Tatsächliches Ergebnis: SIM

Gibt es eine Möglichkeit?
Ich habe anstelle von xlWhole, xlPart versucht, aber das klappt leider nicht :( HIIIIIIIIIIIILFE
 
Mein Code ist folgender:

Private Sub Lst_Abkuerzungen_Click()
    Txt_Abk = Lst_Abkuerzungen
End Sub
Private Sub Txt_Abk_Change()
    Dim LoI As Long                                 ' Schleifenvariable
    Dim LoZeile As Long                             ' Variable für Zeile in Listbox
    Dim RaFound As Range                            ' Variable für das Suchergebnis
    Application.ScreenUpdating = False              ' Bildschirmaktualisierung aus
    If Txt_Abk = "" Then                            ' keine Eingabe in der Textbox
        ' gesamte Liste zuweisen
        Lst_Abkuerzungen.RowSource = "A5:B" & LoLetzte
    Else
        Lst_Abkuerzungen.RowSource = ""           ' Adressbreich für Listbox löschen
        With Worksheets("Tabelle1")
            ' erste Zeile Suchen
            ' letzte belegte Zeile unabhängig von Excelversion für Spalte A (1)
            LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), _
                Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
            Set RaFound = .Range("A5:A" & LoLetzte).Find(Txt_Abk _
                & "*", .Cells(LoLetzte, 1), , xlWhole, , xlNext)
            If Not RaFound Is Nothing Then          ' Begriff wurde gefunden
                ' Schleife von gefundener Stelle bis zu letzten Zeile
                For LoI = RaFound.Row To LoLetzte
                    ' Prüfen ob Abk noch mit dem Inhalt aus
                    ' der Textbox beginnt
                    If UCase(Left(.Cells(LoI, 1), Len(Txt_Abk))) _
                        = UCase(Txt_Abk) Then
                        ' Abk eintragen
                        Lst_Abkuerzungen.AddItem .Cells(LoI, 1)
                        ' Abk eintragen
                        Lst_Abkuerzungen.List(LoZeile, 1) = .Cells(LoI, 2)
                        LoZeile = LoZeile + 1       ' Zeilennummer um 1 erhöhen
                    ' auskommentiert wegen Umlaute
                    'Else
                        'Exit For                   ' Schleife verlasen
                    Else
                        If UCase(Left(.Cells(LoI, 1), 1)) _
                            <> UCase(Left(Txt_Abk, 1)) Then
                            Exit For
                        End If
                    End If
                Next
            End If
        End With
    End If
    Set RaFound = Nothing                           ' Variable leeren
    Application.ScreenUpdating = True               ' Bildschirmaktualiserung ein
End Sub
Private Sub UserForm_Initialize()
    With Worksheets("Tabelle1")
        ' letzte belegte Zeile unabhängig von Excelversion für Spalte A (1)
        LoLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ' Abkbereich der Listbox zuweisen
        Lst_Abkuerzungen.RowSource = "A5:b" & LoLetzte
        Lst_Abkuerzungen.ColumnCount = 2          ' Spaltenanzahl der Listbox einstellen
    End With
End Sub

Ich habe mich schon durch googelt gestürmt, aber es gab bisher keine Lösung, kann mir jemand helfen?

vielen DANK

[newbie69]

anbei ein Bild meiner Sucheingabe.

Es sollte eben (a)Sim auch angezeigt werden :)    

[Kuwer]

Hallo,

teste es mal so (Code komplett austauschen!):

Dialog UserForm1

Option Explicit 

Private Sub Lst_Abkuerzungen_Click() 
 Txt_Abk = Lst_Abkuerzungen 
End Sub 

Private Sub Txt_Abk_Change() 
 Dim rngBereich As Range 
 Dim rngFind As Range 
 Dim strAdresseErsterTreffer As String 
  
 With Worksheets("Tabelle1") 
   Set rngBereich = .Range("A5:A" & IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                         .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)) 
 End With 
  
 If Len(Txt_Abk) Then 
   Lst_Abkuerzungen.Clear 
   Set rngFind = rngBereich.Find(Txt_Abk, After:=rngBereich.Cells(rngBereich.Cells.Count), LookIn:=xlValues) 
   If Not rngFind Is Nothing Then 
     strAdresseErsterTreffer = rngFind.Address 
     Do 
       ' Abk eintragen 
       Lst_Abkuerzungen.AddItem rngFind.Value 
       ' Abk eintragen 
       Lst_Abkuerzungen.List(Lst_Abkuerzungen.ListCount - 1, 1) = rngFind.Offset(0, 1).Value 
       'Nächstes suchen 
       Set rngFind = rngBereich.FindNext(rngFind) 
     Loop Until rngFind.Address = strAdresseErsterTreffer 
   End If 
 Else 
   Lst_Abkuerzungen.List = rngBereich.Resize(, 2).Value 
 End If 
End Sub 

Private Sub UserForm_Initialize() 
 Lst_Abkuerzungen.ColumnCount = 2          ' Spaltenanzahl der Listbox einstellen 
 Txt_Abk_Change 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Typ	Name	Eigenschaften
ListBox	Lst_Abkuerzungen	ColumnCount: 2 Height: 243 Left: 18 TabIndex: 1 Top: 42 Width: 516
TextBox	Txt_Abk	Height: 18 Left: 18 TabIndex: 0 Text: Top: 12 Width: 72

Gruß Uwe

[newbie69]

Hi, danke das ist schonmal ein guter Ansatz, es geht zwar noch nicht zu 100% weil ich ein Stern davor und danach bei der Suchmaske noch eingeben muss, aber damit tauchen schon einmal alle Begriffe, in denen SIM vorkommt auf.

Kann man einen Automatismus einfügen, dass er ein Stern davor und danach einfügt?

ich hoffe, man versteht, was ich meine :P

[newbie69]

oh, ich habs!!

Uwe, ich habe bei deinem Code noch folgendes hinzgefügt

Set rngFind = rngBereich.Find(Txt_Abk, After:=rngBereich.Cells(rngBereich.Cells.Count), LookIn:=xlValues, LookAt:=xlPart)

jetzt klappt es. SAU GUT!!
Danke Uwe!!!

[Kuwer]

Hallo,

ersetze/ergänze den Find-Abschnitt damit:

    Set rngFind = rngBereich.Find(What:=Txt_Abk, _
                                After:=rngBereich.Cells(rngBereich.Cells.Count), _
                               LookIn:=xlValues, _
                               LookAt:=xlPart, _
                            MatchCase:=False)

Setze den Cursor mal auf Find und drücke F1. Da werden alle Suchparameter erklärt.

Gruß Uwe

[newbie69]

Danke, passt jetzt wirklich genial.

Grundsätzliche Frage:

Wenn ich jetzt anstelle von Spalte A, B auch noch C in der Liste angezeigt haben möchte, wie löse ich das Problem?

allein unten auf Column 3 stelle, erzeugt zwar in Liste 3 Spalten, wenn ich aber dann Suche, dann zeigt er nur A und B an :)

[Kuwer]

Hallo Herbert,

für 3. Spalte ist rot markiert:

Option Explicit

Private Sub Lst_Abkuerzungen_Click()
 Txt_Abk = Lst_Abkuerzungen
End Sub

Private Sub Txt_Abk_Change()
 Dim rngBereich As Range
 Dim rngFind As Range
 Dim strAdresseErsterTreffer As String
 
 With Worksheets("Tabelle1")
   Set rngBereich = .Range("A5:A" & IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                         .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count))
 End With
 
 If Len(Txt_Abk) Then
   Lst_Abkuerzungen.Clear
   Set rngFind = rngBereich.Find(What:=Txt_Abk, _
                                After:=rngBereich.Cells(rngBereich.Cells.Count), _
                               LookIn:=xlValues, _
                               lookat:=xlPart, _
                            MatchCase:=False)
   If Not rngFind Is Nothing Then
     strAdresseErsterTreffer = rngFind.Address
     Do
       ' Abk eintragen Spalte 1
       Lst_Abkuerzungen.AddItem rngFind.Value
       ' Abk eintragen Spalte 2
       Lst_Abkuerzungen.List(Lst_Abkuerzungen.ListCount - 1, 1) = rngFind.Offset(0, 1).Value
       ' Abk eintragen Spalte 3
       Lst_Abkuerzungen.List(Lst_Abkuerzungen.ListCount - 1, 2) = rngFind.Offset(0, 2).Value
       'Nächstes suchen
       Set rngFind = rngBereich.FindNext(rngFind)
     Loop Until rngFind.Address = strAdresseErsterTreffer
   End If
 Else
   Lst_Abkuerzungen.List = rngBereich.Resize(, 3).Value
 End If
End Sub

Private Sub UserForm_Initialize()
 Lst_Abkuerzungen.ColumnCount = 3          ' Spaltenanzahl der Listbox einstellen
 Txt_Abk_Change
End Sub

Gruß Uwe

[newbie69]

DANKE! :15: