Suchfunktion mit List Box erweitern

[AndyExcel77]

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 ?

[Steffl]

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

[AndyExcel77]

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

[Kuwer]

Hallo,

If MsgBox("Artikel:" & rC.Value, vbRetryCancel) = vbCancel Then Exit Do

Gruß Uwe

[AndyExcel77]

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

[AndyExcel77]

Hallo, das klappt super , nur leider bleiben die Suchergebnisse Farbig eingefärbt, wenn ich auf abrechen klicke, das müsste noch behoben werden.

DANKE

[Kuwer]

Hallo,

stimmt, also doch etwas umfangreicher:

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

[AndyExcel77]

Super Vielen DANK !!!

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

DANKE