Fortsetzung ListBox-Inhalt ohne Überschrift

Hallo,
leider komme ich erst jetzt dazu, auf die Antwort von Case zu antworten.
Vermutlich ist deshalb der Antwortlink zu https://www.herber.de/forum/archiv/1264to1268/t1267604.htm nicht mehr aktiv, weshalb ein neuer Thread von mir geöffnet wurde.
Mit der Änderung von Case (Beispielsuche mit "e") wird leider nur eine Zeile angezeigt.
Erster Gedanke war, dass die folgenden Leerfelder, welche ich aber in der neuen Beispieltabelle befüllt habe, die Ursache sind. Leider nein.
Da ich momentan das Projekt nicht fortsetzen kann, möchte ich mich wenigstens für die Mithilfe bedanken.
Habe noch eine andere UserForm mit einem Suchcode.
Vielleicht werde ich mir diesen anschauen und ggf. die Suche wie durch Gerd's Rückfrage angeregt über die Spalte KND-Nummer und KND-Name mit getrennter Textbox machen.
Gruß Rainer
https://www.herber.de/bbs/user/80849.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub CommandButton1_Click() Dim xSuche, xAdresse, xErste As String Dim y As Boolean Dim arr() As Variant Dim rng As Range Dim iCounter, iRowU As Integer Dim SuchBer As Range ' ### neu ListBox1.Clear xSuche = TextBox1.Value If xSuche = "" Then MsgBox "Bitte erst einen Suchbegriff eingeben!", vbExclamation, "Achtung!" Exit Sub End If If ComboBox1.Value = "" And CheckBox2.Value = False Then MsgBox "Bitte geben Sie ein, wo der Begriff gesucht werden soll!", _ vbExclamation, "Achtung!" Exit Sub End If For iCounter = 1 To ThisWorkbook.Sheets.Count With Worksheets(iCounter) If CheckBox2.Value = True Or .Name = ComboBox1.Value Then 'Original 'Set rng = Worksheets(iCounter).Cells.Find _ ' (xSuche, lookat:=Suchart, LookIn:=xlValues) 'https://www.herber.de/forum/messages/1267629.html Set SuchBer = .Rows("2:" & .Cells.SpecialCells(xlCellTypeLastCell).Row) ' ### neu Set rng = SuchBer.Find(xSuche, lookat:=Suchart, LookIn:=xlValues) ' ### neu If Not rng Is Nothing Then xErste = rng.Address(False, False) y = True Do Until xAdresse = xErste ReDim Preserve arr(0 To 8, 0 To iRowU) arr(0, iRowU) = .Name arr(1, iRowU) = rng.Address(False, False) arr(2, iRowU) = .Cells(rng.Row, 1) arr(3, iRowU) = .Cells(rng.Row, 2) arr(4, iRowU) = .Cells(rng.Row, 3) arr(5, iRowU) = .Cells(rng.Row, 4) arr(6, iRowU) = .Cells(rng.Row, 5) arr(7, iRowU) = .Cells(rng.Row, 6) arr(8, iRowU) = .Cells(rng.Row, 8) iRowU = iRowU + 1 'Set rng = .Cells.FindNext(after:=rng) Set rng = SuchBer.FindNext(after:=rng) ' ### neu xAdresse = rng.Address(False, False) Loop xAdresse = "" xErste = "" End If End If End With Next iCounter If y = False Then MsgBox "Der Suchbegriff wurde nicht gefunden!" Else ListBox1.Column = arr End If End Sub

Set SuchBer = Worksheets(iCounter).Rows("2:" & Worksheets(iCounter).Cells.SpecialCells( _ xlCellTypeLastCell).Row) ' ### neu Set rng = SuchBer.Find(xSuche, lookat:=Suchart, LookIn:=xlValues) ' ### neu

Hi Rainer,
ein wenig mehr müsstest du schon geändert haben, um mehr als einen Treffer zu erhaltern...
Insbesondere sollte vor ,FindNext "SuchBer" stehen, nicht der letzte Treffer rng - und de hast wohl auch ein
Dim SuchBer ...
Hier kommt jede Zeile höchstens einmal in die Liste (durch die Änderungen mit "### ganz neu":

Private Sub CommandButton1_Click()
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim iCounter, iRowU As Integer
Dim SuchBer As Range, lngMerk As Long                    ' ### ganz neu
ListBox1.Clear
xSuche = TextBox1.Value
If xSuche = "" Then
MsgBox "Bitte erst einen Suchbegriff eingeben!", vbExclamation, "Achtung!"
Exit Sub
End If
If ComboBox1.Value = "" And CheckBox2.Value = False Then
MsgBox "Bitte geben Sie ein, wo der Begriff gesucht werden soll!", vbExclamation, "Achtung!" _
Exit Sub
End If
For iCounter = 1 To ThisWorkbook.Sheets.Count
With Worksheets(iCounter)
If CheckBox2.Value = True Or .Name = ComboBox1.Value Then
Set SuchBer = .Rows("2:" & .Cells.SpecialCells(xlCellTypeLastCell).Row) ' ### neu
Set rng = SuchBer.Find(xSuche, LookIn:=xlValues, lookat:=Suchart, _
SearchOrder:=xlByRows)                                           ' ### ganz neu
If Not rng Is Nothing Then
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
If lngMerk  rng.Row Then                                   ' ### ganz neu
lngMerk = rng.Row                                          ' ### ganz neu
ReDim Preserve arr(0 To 8, 0 To iRowU)
arr(0, iRowU) = .Name
arr(1, iRowU) = rng.Address(False, False)
arr(2, iRowU) = .Cells(rng.Row, 1)
arr(3, iRowU) = .Cells(rng.Row, 2)
arr(4, iRowU) = .Cells(rng.Row, 3)
arr(5, iRowU) = .Cells(rng.Row, 4)
arr(6, iRowU) = .Cells(rng.Row, 5)
arr(7, iRowU) = .Cells(rng.Row, 6)
arr(8, iRowU) = .Cells(rng.Row, 8)
iRowU = iRowU + 1
End If                                                       ' ### ganz neu
Set rng = SuchBer.FindNext(after:=rng)                     ' ### neu
xAdresse = rng.Address(False, False)
Loop
xAdresse = ""
xErste = ""
End If
End If
End With
Next iCounter
If y = False Then
MsgBox "Der Suchbegriff wurde nicht gefunden!"
Else
ListBox1.Column = arr
End If
End Sub

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Beliebteste Forumthreads (12 Monate)

Fortsetzung ListBox-Inhalt ohne Überschrift

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Fortsetzung ListBox-Inhalt ohne Überschrift

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread