mreske
Goto Top

Suche nach Spalte B,C,D mit Ausgabe in einer Listbox

Hallo,
ich habe eine UserForm mit einer Suchanfrage, die die Spalte D (Artikelbezeichnung) einer Tabelle durchsucht (With ActiveSheet.Range("D:D").
Die Suchergebnisse werden in einer Listbox ausgegeben.
Das funktioniert soweit auch bestens.

Da ich hin und wieder aber auch mal nach der Artikelnummer (anstatt nach der Bezeichnung) suchen muss,
möchte ich in der Tabelle die Spalten B bis D durchsuchen (With ActiveSheet.Range("B:D")
Das geht auch soweit.

Problematisch wird es jedoch bei der Ausgabe in der Listbox:
Bei der Ausgabe der Suche in Spalte D werden ja die Ergebnisse jeweils links und rechts der Spalte D so ausgegeben:

With lbResults
.AddItem
.List(.ListCount - 1, 0) = rngFound.Offset(0, -3).Value 'ID
.List(.ListCount - 1, 1) = rngFound.Offset(0, -2).Value ' ArtNr.
.List(.ListCount - 1, 2) = rngFound.Offset(0, -1).Value ' MEH
.List(.ListCount - 1, 3) = rngFound.Value ' Bezeichnung
.List(.ListCount - 1, 4) = rngFound.Offset(0, 1).Value ' Bezeichnung lang
.List(.ListCount - 1, 5) = rngFound.Offset(0, 2).Value ' Info
End With

Das funktioniert aber nicht mehr, wenn der Treffer in der Spalte B gefunden wurde.
Wie müsste ich den Quellcode anpassen, damit mir die Ausgabe immer in der gleichen Reihenfolge angezeigt wird (egal in welcher Spalte der Treffer erzielt wurde)?

2018-07-03_143217

Hier mal der Quellcode (ich würde ja auch die beiden Tabellen tbl_ArtStamm.xlsx und Artikelsuche.xlsm hochladen,
aber das geht hier wohl nicht....

Private Sub txtSearch_AfterUpdate()
Application.ScreenUpdating = False

Dim appExcel As Excel.Application
Dim wbkExcel As Excel.Workbook
Dim wksExcel As Excel.Worksheet
 
Set appExcel = Excel.Application
Set wbkExcel = Excel.Workbooks.Open("C:\VBA\tbl_ArtStamm.xlsx", ReadOnly:=True)  
Set wksExcel = Excel.Worksheets("ArtStamm")  
Set rngExcel = wksExcel.UsedRange

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
Windows("tbl_ArtStamm.xlsx").Activate  

Dim Suchbegriff As String
Suchbegriff = Me.txtSearch
If Right$(Suchbegriff, 1) = " " Then 'Wenn das letzte Zeichen ein Leerzeichen ist, gibt es keine Suchtreffer  
'Also letztes Leerzeichen entfernen  
Me.txtSearch.Text = Left(Me.txtSearch, Len(Me.txtSearch) - 1)
Else
'Sonst nichts entfernen  
End If

With ActiveSheet.Range("D:D")  
arrSearchTerms = Split(txtSearch.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, -3).Value 'ID  
.List(.ListCount - 1, 1) = rngFound.Offset(0, -2).Value ' ArtNr.  
.List(.ListCount - 1, 2) = rngFound.Offset(0, -1).Value ' MEH  
.List(.ListCount - 1, 3) = rngFound.Value ' Bezeichnung  
.List(.ListCount - 1, 4) = rngFound.Offset(0, 1).Value ' Bezeichnung lang  
.List(.ListCount - 1, 5) = rngFound.Offset(0, 2).Value ' Info  
End With
End If
Next
Else
'Keine Suchergebnisse  
MsgBox "Keine Einträge gefunden!", vbExclamation  
End If
End With

'Überschriften  
lbResults.ColumnCount = 7
lbResults.ColumnWidths = "0,00Pt; 42,5Pt; 28,35Pt; 198,45Pt; 0,00Pt; 0,00Pt; 0,00Pt"  
Me.lbResultsHeader.RowSource = ActiveSheet.Range("A1:G1").Address  

wbkExcel.Close
Application.ScreenUpdating = True
End Sub

Vielen Dank im Voraus

Content-Key: 378957

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

Ausgedruckt am: 28.03.2024 um 08:03 Uhr

Mitglied: emeriks
Lösung emeriks 03.07.2018, aktualisiert am 04.07.2018 um 08:15:05 Uhr
Goto Top
Hi,
Du machst Das zwar etwas umständlich, aber in Zeile 58 "holst" Du Dir "rngFound". Das sollte dann genau eine Zelle sein.
Jetzt musst Du also erstes die Spalte dieser Zelle auswerten und abhängig davon in Zeilen 62 bis 67 mit anderen Offsets arbeiten.

E.
Mitglied: mreske
mreske 03.07.2018 aktualisiert um 17:41:37 Uhr
Goto Top
Vielen Dank emeriks,
warum bin ich da nicht selber drauf gekommen...face-smile
Ich baue deinen Tipp ein und setze ihn dann hier ins Forum.
Vielen Dank (klasse Forum)...
Mitglied: mreske
mreske 04.07.2018 um 14:29:41 Uhr
Goto Top
Hallo emeriks,

sicher gibt es elegantere Wege, das zu programmieren, aber für meine Zwecke reicht es alle Male:

Ab Zeile 56 muss der Code wie folgt geändert werden:

For I = 0 To dic.Count - 1
If dic.Item(keys(I)) = UBound(arrSearchTerms) + 1 Then

If ActiveSheet.Range(keys(I)).Column = 2 Then    'Suche nach der Artikelnummer in Spalte B  

Set rngFound = ActiveSheet.Range(keys(I))

With lbResults
.AddItem
.List(.ListCount - 1, 0) = rngFound.Offset(0, -1).Value 'ID  
.List(.ListCount - 1, 1) = rngFound.Value ' ArtNr.  
.List(.ListCount - 1, 2) = rngFound.Offset(0, 1).Value ' MEH  
.List(.ListCount - 1, 3) = rngFound.Offset(0, 2).Value ' Bezeichnung  
.List(.ListCount - 1, 4) = rngFound.Offset(0, 3).Value ' Bezeichnung lang  
.List(.ListCount - 1, 5) = rngFound.Offset(0, 4).Value ' Info  
End With

ElseIf ActiveSheet.Range(keys(I)).Column = 4 Then      'Suche nach der Bezeichnung in Spalte D  

Set rngFound = ActiveSheet.Range(keys(I))
With lbResults
.AddItem
.List(.ListCount - 1, 0) = rngFound.Offset(0, -3).Value 'ID  
.List(.ListCount - 1, 1) = rngFound.Offset(0, -2).Value ' ArtNr.  
.List(.ListCount - 1, 2) = rngFound.Offset(0, -1).Value ' MEH  
.List(.ListCount - 1, 3) = rngFound.Value ' Bezeichnung  
.List(.ListCount - 1, 4) = rngFound.Offset(0, 1).Value ' Bezeichnung lang  
.List(.ListCount - 1, 5) = rngFound.Offset(0, 2).Value ' Info  
End With

End If
End If
Next

Else
'Keine Suchergebnisse  
MsgBox "Keine Einträge gefunden!", vbExclamation  
End If
End With

wbkExcel.Close
Application.ScreenUpdating = True
End Sub