mreske
Jun 07, 2016, updated at Jun 08, 2016 (UTC)
view1862
view12
0
Goto Top

Spalte E nach beliebig vielen Suchbegriffen (mit Leerzeichen getrennt) durchsuchen und in Listbox ausgeben

GermansolvedQuestionMicrosoft OfficeMicrosoft
Hallo
ich habe eine Excel Tabelle mit einem Artikelstamm, in dem in der Spalte E die ARTIKELBEZEICHNUNG steht.
Ich möchte diese Spalte nach mehreren Suchkriterien (durch Leerzeichen getrennt) durchsuchen.

Der Suchbegriff könnte z.B lauten:
Jacke oran xxl Kapu

Die Eingabe der Suchbegriffe erfolgt über die Textbox: txt_Suche
Die Treffer sollen in der Listbox ausgegeben werden: dblst_Treffer

Ausgegeben in der Listbox werden soll dann:
Winterjacke gefüttert orange XXL mit knöpfbarer Kapuze
Sommerjacke XXL orange gelb mit angenähter Kapuze

Nach nur einem Suchbegriff kann ich mit unten angegebenem Makro suchen.
Ich möchte jedoch, wie oben beschrieben, nach mehreren Suchbegriffen suchen.
Hat hier jemand eine Idee, wie man das Makro unten umbauen müsste?

Private Sub txt_Suche_AfterUpdate()
Dim wbkExcel As Excel.Workbook
Dim wksExcel As Excel.Worksheet
Dim rngExcel As Excel.Range
Dim rngCell As Range
Dim strFirstAddress As String
Dim Suchwort As String
 
Set appExcel = Excel.Application
Set wbkExcel = Excel.Workbooks.Open("C:\tbl_ArtStamm.xlsx", ReadOnly:=True)  
Set wksExcel = Excel.Worksheets("ArtStamm")  
Set rngExcel = wksExcel.UsedRange

Suchwort = ("*" & Me.txt_Suche.Value & "*")   ' hier möchte ich aber beliebig viele Suchbegriffe (mit Leerzeichen getrennt eingeben)  

With wksExcel.Range("E:E")  
Me.dblst_Treffer.Clear
Set rngExcel = .Find(Suchwort, LookIn:=xlValues, lookat:=xlWhole)
If Not rngExcel Is Nothing Then
strFirstAddress = rngExcel.Address
Do
With Me.dblst_Treffer 
.ColumnCount = 1
AddItem 
.List(.ListCount - 1, 4) = rngExcel.Text   
.ColumnWidths = "5cm"  
End With
Set rngExcel = .FindNext(rngExcel)
Loop While Not rngExcel Is Nothing And rngExcel.Address <> strFirstAddress
Else
End If
End With
wbkExcel.Close
End Sub

Gruß
mre
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 306441

Url: https://administrator.de/contentid/306441

Printed on: May 3, 2024 at 05:05 o'clock

12 Comments
Latest comment
Goto Top
Member: em-pie
em-pie Jun 07, 2016 at 21:54:19 (UTC)
Goto Top
Hi,

Zwar keine fertige Lösung, aber vielleicht ein Denkanstoss:

Warum zergliederst du deinen Suchbegriff nicht in ein Array, Trennzeichen ist das Leerzeichen, und durchsuchst deine Felder mit jedem Array-eintrag.
Das Ergebnis jedes Schleifendurchlaufs listet du dann auf.

Gruß
em-pie
Member: mreske
mreske Jun 08, 2016 at 04:23:52 (UTC)
Goto Top
Hallo em-pi
danke für die schnelle Rückmeldung. Mit Arrays habe ich noch nicht gearbeitet.

In Access müsste mein Makro so funktionieren.

Private Sub txt_Suche_AfterUpdate()
Dim i As Integer
Dim varKrit As Variant
Dim strKrit As String
    
strKrit = ""  
If Not Trim(Me!txt_Suche) = "" Then  
varKrit = Split(Trim(Me!txt_Suche), " ")  
For i = 0 To UBound(varKrit)
strKrit = strKrit & " AND [BeschrKurz] Like '*" & varKrit(i) & "*'"              ' [BeschrKurz] wäre in meiner Excel Tab = Spalte E  

Next i
strKrit = Mid(strKrit, 5)
Me.qryArtikelUnterformular.Form.Filter = strKrit 'Filter = strKrit  
Me.qryArtikelUnterformular.Form.FilterOn = True '.FilterOn = True  
End If
End Sub
Mitglied: 129413
129413 Jun 08, 2016 at 05:40:34 (UTC)
Goto Top
Ich würde das mit einem Dictionary-Object machen in dem ich die Suchbegriffe erst per Split und dem Leerzeichen auftrenne und dann per Schleife jeden Suchbegriff in die Suche injiziere und dann bei Erfolg den Namen der Zelle in das Dictionary eintrage. Kommt dann eine Zelle die schon im Dictionary steht zähle ich zum Wert der Zelle im Dictionary 1 hinzu. Zum Schluss durchlaufe ich das Dictionary und prüfe ob der Wert dem UBound() des Splits entspricht, wenn das der Fall ist (d.h. also das alle Begriffe in der Zelle vorkommen) übernehme ich den Zellwert in die Listbox ansonsten nicht.

Gruß Skybird
Member: colinardo
Solution colinardo Jun 08, 2016 updated at 08:06:45 (UTC)
Goto Top
Hallo mre,
so wie deine Beschreibung formuliert ist, gehe ich einfach mal davon aus das alle deine Suchwörter in einem Artikel vorhanden sein müssen den du suchst. In dem Fall schau dir das Demo-Sheet dazu an:
multiwort_artikelsuche_306441.xlsm

Grüße Uwe
heart1
Member: mreske
mreske Jun 08, 2016 at 16:27:15 (UTC)
Goto Top
Hallo colinardo,
dein Demo-Sheet funktioniert ganz genau so, wie ich es mir vorgestellt hatte.

Private Sub btnSearch_Click()
    Dim strSearchTerm As String, dic As Object, arrSearchTerms As Variant, firstAddress As String, c As Range, keys As Variant
    Set dic = CreateObject("Scripting.Dictionary")  
    lbResults.Clear
    With ActiveSheet.Range("E:E")  
        arrSearchTerms = Split(txtSearchTerms.Text, " ", -1, vbTextCompare)  
        'Suche jedes Wort  
        For i = 0 To UBound(arrSearchTerms)
            'Suche durchführen  
            Set c = .Find(arrSearchTerms(i), LookIn:=xlValues, Lookat:=xlPart)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If i <> 0 Then
                        'Es wurde schon nach dem ersten Suchwort gesucht also zähle nur 1 hinzu wenn die gefundene Zelle im Dictionary enthalten ist  
                        If dic.Exists(c.Address) Then
                            dic.Item(c.Address) = dic.Item(c.Address) + 1
                        End If
                    Else
                        'Erstes Suchwort, also füge es zum Dictionary hinzu  
                        dic.Add c.Address, 1
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        Next
        'Wenn Suchergebnisse da sind ...  
        If dic.Count > 0 Then
            ' Durchlaufe alle Einträge im Dictionary und prüfe ob der Wert der Anzahl der Suchworte entspricht.  
            ' Wenn ja, füge ihn zur Listbox hinzu  
            keys = dic.keys()
            For i = 0 To dic.Count - 1
                If dic.Item(keys(i)) = UBound(arrSearchTerms) + 1 Then
                    lbResults.AddItem ActiveSheet.Range(keys(i)).Value
                End If
            Next
        Else
            'Keine Suchergebnisse  
            MsgBox "Keine Einträge gefunden!", vbExclamation  
        End If
    End With
End Sub

Tausend Dank dafür
mre
Member: mreske
mreske Jun 08, 2016 updated at 17:23:47 (UTC)
Goto Top
Hallo Colinardo,
dein o.g. Code gibt mir jetzt die Suchergebnisse der Spalte E in der Listbox aus.
Ist es hier auch möglich, mir die anderen Spalten A, B, C, D, F, G, H auch in der Listbox anzeigen zu lassen.

Vorher hatte ich diese Spalten ausgegeben mit:

.ColumnCount = 7
.ColumnWidths = "2cm;2cm;2cm;5cm;2cm;2cm;2cm"  
.AddItem 
.List(.ListCount - 1, 0) = rngExcel.Offset(0, -3).Value     'ID  
.List(.ListCount - 1, 1) = rngExcel.Offset(0, -2).Value     'ArtNr  
.List(.ListCount - 1, 2) = rngExcel.Offset(0, -1).Value     'ME  
.List(.ListCount - 1, 3) = rngExcel.Offset(0, -0).Value     'BeschrKurz  -> Die Treffer in dieser Spalte werden ja schon ausgegeben  
.List(.ListCount - 1, 4) = rngExcel.Offset(0, 1).Value     'BeschrLang  
.List(.ListCount - 1, 5) = rngExcel.Offset(0, 2).Value     'KategIntern

Danke
Member: colinardo
colinardo Jun 08, 2016 updated at 17:44:52 (UTC)
Goto Top
Ja kannst du, in meinem Code ist das die Zeile 34
Hier kannst du ebenfalls per Offset auf die Spalten zugreifen
ActiveSheet.Range(keys(i)).Offset(0,X).Value

Alternativ kann man die List-Eigenschaft auch mit weniger Zeilen füllen indem man mit Ranges die List-Eigenschaft füllt.
Member: mreske
mreske Jun 08, 2016 at 17:48:08 (UTC)
Goto Top
Damit schreibt er mir die Ergebnisse in der Listbox untereinander und nicht nebeneinander in einer Zeile.
Was mache ich da falsch (ich kenne mich mit den Listboxen noch nicht so aus, sorry)

ActiveSheet.Range(keys(i)).Offset(0,-3).Value
ActiveSheet.Range(keys(i)).Offset(0,-2).Value
ActiveSheet.Range(keys(i)).Offset(0,-1).Value
etc.
Member: colinardo
colinardo Jun 08, 2016 updated at 17:53:53 (UTC)
Goto Top
Ja nee, ich meinte das du diese Zeile statt dem rngExcel.Offset(0, -3).Value in deinem Code verwendet hättest ...
Member: mreske
mreske Jun 08, 2016 at 18:23:36 (UTC)
Goto Top
Also, ich wollte DEINEN Code so umbauen, dass mir auch die anderen Spalten angezeigt werden.

2016-06-08_201817
Member: colinardo
Solution colinardo Jun 08, 2016 updated at 18:38:21 (UTC)
Goto Top
Logisch, na dann muss ich es wohl wieder vorbeten ...
multiwort_artikelsuche_2_306441.xlsm

Grüße und schönen Abend
Uwe
Member: mreske
mreske Jun 08, 2016 at 18:36:58 (UTC)
Goto Top
Tausend Dank!! - genau das habe ich gesucht.

Private Sub btnSearch_Click()
    Dim strSearchTerm As String, dic As Object, arrSearchTerms As Variant, firstAddress As String, c As Range, keys As Variant
    Set dic = CreateObject("Scripting.Dictionary")  
    lbResults.Clear
    With ActiveSheet.Range("E:E")  
        arrSearchTerms = Split(txtSearchTerms.Text, " ", -1, vbTextCompare)  
        'Suche jedes Wort  
        For i = 0 To UBound(arrSearchTerms)
            'Suche durchführen  
            Set c = .Find(arrSearchTerms(i), LookIn:=xlValues, Lookat:=xlPart)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If i <> 0 Then
                        'Es wurde schon nach dem ersten Suchwort gesucht also zähle nur 1 hinzu wenn die gefundene Zelle im Dictionary enthalten ist  
                        If dic.Exists(c.Address) Then
                            dic.Item(c.Address) = dic.Item(c.Address) + 1
                        End If
                    Else
                        'Erstes Suchwort, also füge es zum Dictionary hinzu  
                        dic.Add c.Address, 1
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        Next
        'Wenn Suchergebnisse da sind ...  
        If dic.Count > 0 Then
            ' Durchlaufe alle Einträge im Dictionary und prüfe ob der Wert der Anzahl der Suchworte entspricht.  
            ' Wenn ja, füge ihn zur Listbox hinzu  
            Set rngResult = Nothing
            keys = dic.keys()
            For i = 0 To dic.Count - 1
                If dic.Item(keys(i)) = UBound(arrSearchTerms) + 1 Then
                    Set rngFound = ActiveSheet.Range(keys(i))
                    With lbResults
                        .AddItem
                        .List(.ListCount - 1, 0) = rngFound.Offset(0, -4).Value
                        .List(.ListCount - 1, 1) = rngFound.Offset(0, -3).Value
                        .List(.ListCount - 1, 2) = rngFound.Offset(0, -2).Value
                        .List(.ListCount - 1, 3) = rngFound.Offset(0, -1).Value
                        .List(.ListCount - 1, 4) = rngFound.Value
                        .List(.ListCount - 1, 5) = rngFound.Offset(0, 1).Value
                    End With
                End If
            Next
        Else
            'Keine Suchergebnisse  
            MsgBox "Keine Einträge gefunden!", vbExclamation  
        End If
    End With
End Sub



Vielen Dank und dir einen schönen Abend noch!
Gruß
mre
GermansolvedQuestionMicrosoft OfficeMicrosoft
Hotly discussed
DaniEnd of availability for classic Teams clientDani - 2 CommentsFrankUbuntu 24.04 LTS Noble Numbat availableFrankadmtechDeveloper diary: Release 6.1admtech