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: