Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Suchfunktion mit List Box erweitern
#1
Hallo,

ich habe folgende Suchfunktion bei mir per Schaltfläche zum Aktivieren als Code

Sub Suchfunktion()
   Dim bFound As Boolean
   Dim rC As Range
   Dim tAddr As String
   Dim tSearch As String
   tSearch = InputBox("Suche nach:", "Suchen")
   If tSearch = "" Then Exit Sub
   With ActiveSheet.Cells
       Set rC = .Find(tSearch, LookIn:=xlValues)
       If Not rC Is Nothing Then
           tAddr = rC.Address
           Do
               rC.Select
               rC.Interior.ColorIndex = 4
               MsgBox "Artikel:" & rC.Value
               rC.Interior.ColorIndex = 2
               bFound = True
               Set rC = .FindNext(rC)
           Loop While Not rC Is Nothing And rC.Address <> tAddr
       End If
   End With
   If Not bFound Then MsgBox "Begriff [" & tSearch & "] nicht gefunden!"
End Sub


Ich würde noch gerne das die Suchergebnisse zusammen in einer List box stehen und mir angezeigt werden ( dazu sollen die werte in den nebenstehenden Zeilen auch angezeigt werden)


also im Beispiel unten sollen die Inhalte von  B12 und C12 sowie D12 mit in der List box angezeigt werden
Also in meiner Tabelle immer die Spalten B C und d nebenstehend

Ist das möglich ?
Antworten Top
#2
Hallo,

mal ungetestet (sollte zumindest für B12 und C12 klappen)

Code:
Sub Suchfunktion()
   Dim bFound As Boolean
   Dim rC As Range
   Dim tAddr As String
   Dim tSearch As String
   Dim lngC As Long
   tSearch = InputBox("Suche nach:", "Suchen")
   If tSearch = "" Then Exit Sub
   With ActiveSheet.Cells
       Set rC = .Find(tSearch, LookIn:=xlValues)
       If Not rC Is Nothing Then
           tAddr = rC.Address
           Do
               rC.Select
               rC.Interior.ColorIndex = 4
               listbox1.AddItem r.Value
               listbox1.List(lngC, 1) = r.Offset(, 1).Value
               lngC = lngC + 1
               MsgBox "Artikel:" & rC.Value
               rC.Interior.ColorIndex = 2
               bFound = True
               Set rC = .FindNext(rC)
           Loop While Not rC Is Nothing And rC.Address <> tAddr
       End If
   End With
   If Not bFound Then MsgBox "Begriff [" & tSearch & "] nicht gefunden!"
End Sub
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#3
Hallo,

und danke

Ich habe noch ein Problem,

wenn ich die Suchfunktion aktiviere, kann ich Sie nicht abbrechen bis alle Ergebnisse angezeigt wurden!

Bitte um abhilfe

hier noch mal der Code ->

Sub Suchfunktion()
   Dim bFound As Boolean
   Dim rC As Range
   Dim tAddr As String
   Dim tSearch As String
   tSearch = InputBox("Suche nach:", "Suchen")
   If tSearch = "" Then Exit Sub
   With ActiveSheet.Cells
       Set rC = .Find(tSearch, LookIn:=xlValues)
       If Not rC Is Nothing Then
           tAddr = rC.Address
           Do
               rC.Select
               rC.Interior.ColorIndex = 4
               MsgBox "Artikel:" & rC.Value
               rC.Interior.ColorIndex = 2
               bFound = True
               Set rC = .FindNext(rC)
           Loop While Not rC Is Nothing And rC.Address <> tAddr
       End If
   End With
   If Not bFound Then MsgBox "Begriff [" & tSearch & "] nicht gefunden!"
End Sub
Antworten Top
#4
Hallo,
If MsgBox("Artikel:" & rC.Value, vbRetryCancel) = vbCancel Then Exit Do
Gruß Uwe
Antworten Top
#5
(14.12.2016, 07:43)Kuwer schrieb: Hallo,
If MsgBox("Artikel:" & rC.Value, vbRetryCancel) = vbCancel Then Exit Do
Gruß Uwe

Hallo, das klappt super , nur leider lässt er mir die Ergebnisse farbig stehen, wenn ich auf abbrechen klicke, das müsste noch behoben werden, DANKE
Antworten Top
#6
Hallo, das klappt super , nur leider bleiben die Suchergebnisse Farbig eingefärbt, wenn ich auf abrechen klicke, das müsste noch behoben werden.

DANKE
Antworten Top
#7
Hallo,

stimmt, also doch etwas umfangreicher: Smile
Sub Suchfunktion()
  Dim bFound As Boolean, bCancel As Boolean
  Dim rC As Range
  Dim tAddr As String
  Dim tSearch As String
  tSearch = InputBox("Suche nach:", "Suchen")
  If tSearch = "" Then Exit Sub
  With ActiveSheet.Cells
      Set rC = .Find(tSearch, LookIn:=xlValues)
      If Not rC Is Nothing Then
          tAddr = rC.Address
          Do
              rC.Select
              rC.Interior.ColorIndex = 4
              bCancel = MsgBox("Artikel:" & rC.Value, vbRetryCancel) = vbCancel
              rC.Interior.ColorIndex = 0
              bFound = True
              Set rC = .FindNext(rC)
          Loop While Not rC Is Nothing And rC.Address <> tAddr And Not bCancel
      End If
  End With
  If Not bFound Then MsgBox "Begriff [" & tSearch & "] nicht gefunden!"
End Sub
Gruß Uwe
Antworten Top
#8
Super Vielen DANK !!!

Das mit der List box öffne ich noch einmal neu das ist dann wohl auch umfangreicher

DANKE
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste