Gesuchte Werte auflisten???

Private Sub Suchen() Const suchname = "NICHT GEFUNDEN" Dim ware As String, stk As String, bestellt As String On Error GoTo Fehler Workbooks("Test1.xls").Activate Sheets("Tabelle1").Activate Columns("D:D").Select Do While ActiveCell.Value <> "" Selection.Find(What:=suchname, After:=ActiveCell, LookIn:= _ xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _ xlNext, MatchCase:=False).Activate With ActiveCell ware = .Offset(0, -3).Value stk = .Offset(0, -2).Value bestellt = .Offset(0, -1).Value End With [a16].Value = ware [b16].Value = stk [c16].Value = bestellt Loop Fehler: MsgBox "Keine Einträge gefunden!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Harald,
versuch es mal so:


Option Explicit
Public Sub Suchen()
Const suchname = "NICHT GEFUNDEN"
Dim Zeile As Long, Zelle As Range, Zeilenfeld() As Long, Adresse As String
Dim index As Long, Spalte As Integer
With Workbooks("Test1.xls").Sheets("Tabelle1")
With .Range(Cells(1, 4), Cells(65536, 4))
Set Zelle = .Find(What:=suchname, LookIn:=xlValues, LookAt:=xlPart)
If Not Zelle Is Nothing Then
Adresse = Zelle.Address
Do
index = index + 1
ReDim Preserve Zeilenfeld(1 To index)
Zeilenfeld(index) = Zelle.Row
Set Zelle = .FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> Adresse
Call sortieren(1, index, Zeilenfeld)
Zeile = 16
For index = 1 To UBound(Zeilenfeld)
For Spalte = 1 To 3
Worksheets(2).Cells(Zeile, Spalte) = Cells(Zeilenfeld(index), Spalte)
Next
Zeile = Zeile + 1
Next
Else
MsgBox "Keine Einträge gefunden!", 48, "Hinweis"
End If
End With
End With
End Sub
Private Sub sortieren(Untergrenze As Long, Obergrenze As Long, Zeilenfeld() As Long)
Dim index1 As Long, index2 As Long, Element As Long, Zwischenspeicher As Long
index1 = Untergrenze
index2 = Obergrenze
Zwischenspeicher = Zeilenfeld(((Untergrenze + Obergrenze) / 2) \ 1)
Do
Do While Zeilenfeld(index1) < Zwischenspeicher
index1 = index1 + 1
Loop
Do While Zwischenspeicher < Zeilenfeld(index2)
index2 = index2 - 1
Loop
If index1 <= index2 Then
Element = Zeilenfeld(index1)
Zeilenfeld(index1) = Zeilenfeld(index2)
Zeilenfeld(index2) = Element
index1 = index1 + 1
index2 = index2 - 1
End If
Loop Until index1 > index2
If Untergrenze < index2 Then Call sortieren(Untergrenze, index2, Zeilenfeld)
If index1 < Obergrenze Then Call sortieren(index1, Obergrenze, Zeilenfeld)
End Sub

Code eingefügt mit: Excel Code Jeanie
Gruß
Nepumuk

Sub Auflisten() Dim ware As String, stk As String, bestellt As String Const suchname = "NICHT GEFUNDEN" Const blatt = "Tabelle1" Workbooks("Test1.xls").Activate Worksheets(blatt).Activate Range("H1").Activate Do While ActiveCell.Value <> "" If ActiveCell.Value = suchname Then With ActiveCell Ware = .Offset(0, -3).Value stk = .Offset(0, -2).Value bestellt = .Offset(0, -1).Value End With [a16].Value = Ware [b16].Value = stk [c16].Value = bestellt End If goend Loop MsgBox "Aus!" End Sub

Option Explicit Public Sub Auflisten() Dim ware As String, stk As String, bestellt As String, zeile As Long Const suchname = "NICHT GEFUNDEN" Const blatt = "Tabelle1" zeile = 16 Workbooks("Test1.xls").Activate Worksheets(blatt).Activate Range("H1").Activate Do While ActiveCell.Value <> "" If ActiveCell.Value = suchname Then With ActiveCell ware = .Offset(0, -3).Value stk = .Offset(0, -2).Value bestellt = .Offset(0, -1).Value End With With Worksheets(2) .Cells(zeile, 1).Value = ware .Cells(zeile, 2).Value = stk .Cells(zeile, 3).Value = bestellt End With zeile = zeile + 1 End If goend Loop MsgBox "Aus!" End Sub Public Sub goend(Optional n As Integer) If n = 0 Then n = 1 End If ActiveCell.Offset(n, 0).Select End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread