Werte aus Sheets kopieren
02.06.2015 11:11:32
Stefan
Ich will ALLE sheets bis auf eins nach einem bestimmten Wert (z.B. 100) durchsuchen. Wenn der Wert größer/gleich 100 ist, sollen die betroffenen Zellen in ein Sheet "All" kopiert werden. Am besten immer in die nächste freie Zeile, falls noch Werte dazu kommen.
Sub test()
Dim source As Worksheet
Dim all As Worksheet
Dim rngFound As Range
Dim wert As Worksheet
Set all = Worksheets("All")
Set wert = Worksheets("Wert")
For i = Sheets.Count To 1 Step -1
Set source = Worksheets(i)
If Sheets(i).Name "Menu" Then
Set rngFound = source.Range("N:N").Find(What:=source.Range("N:N").Value > 100, LookIn:= _
xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
all.Range("A6:A10").Value = rngFound.Offset(1).Resize(5).Value
End If
End If
Next i
End Sub
Vielleicht habt ihr ja eine Idee.
Grüße,
Stefan