AW: bestimmte Werte aus einer Liste
10.11.2009 13:57:21
Chris
Servus Ludicla,
als Makro:
Sub tt()
Dim lngLetzte As Long
Dim rSuche As Range, rFinde As Range, strErste As String, datenArray(), lngZähler As Long, _
ZeilenArray() As Long, x As Long, i As Long, k As Long, lngLauf As Long
lngLetzte = Sheets("Preisblatt").Cells(65536, 2).End(xlUp).Row
Set rFinde = Sheets("Preisblatt").Range("B2:B" & lngLetzte)
Set rSuche = rFinde.Find(what:=ActiveSheet.Cells(3, 1), Lookat:=xlWhole, LookIn:=xlValues)
If Not rSuche Is Nothing Then
strErste = rSuche.Address
Do
ReDim Preserve ZeilenArray(x)
ZeilenArray(x) = rSuche.Row
x = x + 1
zähler = zähler + 1
Set rSuche = rFinde.FindNext(rSuche)
Loop While Not rSuche Is Nothing And rSuche.Address strErste
Else
Exit Sub
End If
ReDim datenArray(1 To zähler, 1 To 12)
For i = LBound(ZeilenArray()) To UBound(ZeilenArray())
lngLauf = ZeilenArray(i)
datenArray(i + 1, 1) = Sheets("Preisblatt").Cells(lngLauf, 2)
datenArray(i + 1, 2) = Sheets("Preisblatt").Cells(lngLauf, 4)
datenArray(i + 1, 3) = Sheets("Preisblatt").Cells(lngLauf, 5)
datenArray(i + 1, 4) = Sheets("Preisblatt").Cells(lngLauf, 6)
datenArray(i + 1, 5) = Sheets("Preisblatt").Cells(lngLauf, 7)
datenArray(i + 1, 6) = Sheets("Preisblatt").Cells(lngLauf, 8)
datenArray(i + 1, 7) = Sheets("Preisblatt").Cells(lngLauf, 9)
datenArray(i + 1, 8) = Sheets("Preisblatt").Cells(lngLauf, 10)
datenArray(i + 1, 9) = Sheets("Preisblatt").Cells(lngLauf, 11)
datenArray(i + 1, 10) = Sheets("Preisblatt").Cells(lngLauf, 12)
datenArray(i + 1, 11) = Sheets("Preisblatt").Cells(lngLauf, 13)
datenArray(i + 1, 12) = Sheets("Preisblatt").Cells(lngLauf, 14)
Next i
For i = 1 To UBound(datenArray(), 1)
For k = 1 To UBound(datenArray(), 2)
ActiveSheet.Cells(i + 6, k) = datenArray(i, k)
Next k
Next i
End Sub
Das Makro mommt in ein Modul und wird entweder über Alt+F8 und oder über extras Makros aufgerufen. Ich habe dir das in der Beispieldatei schon erledigt.
Gewünschtes Sheet aktivieren, Den Suchbegriff im aktiven Sheet (hier HallenBad Süd-West) in A3 eintragen und Makro starten.
https://www.herber.de/bbs/user/65730.xls
Gruß
Chris