Werte aus Sheets kopieren

Bild

Betrifft: Werte aus Sheets kopieren
von: Stefan
Geschrieben am: 02.06.2015 11:11:32

Huhu, ich schon wieder.
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
Ich komm mit der Wert-Prüfung nicht klar.
Vielleicht habt ihr ja eine Idee.
Grüße,
Stefan

Bild

Betrifft: AW: Werte aus Sheets kopieren
von: Michael
Geschrieben am: 02.06.2015 17:20:04
Hallo Stefan,
Ideen hätten wir gar viele, aber...
.Find entspricht Excels Suchfunktion unter Strg+f, und da kann man halt nur nach Begriffen, aber nicht nach "Begriff größer/gleich" suchen.
Es würde sich anbieten, einen Filter im jeweiligen Blatt zu setzen (das Kopieren gefilterter Werte ist machbar, siehe https://www.herber.de/forum/archiv/1424to1428/t1427649.htm#1427649
aber es stellt sich heraus, daß Du gar nicht die gefundenen Werte kopieren willst, sondern die 5, die in den Zeilen jeweils *darunter* liegen.
Dazu fällt mir nichts anderes ein, als sowohl auf .Find als auch den Filter zu verzichten, und die vorhandenen Zeilen in N:N händisch in einer Schleife zu durchlaufen:

Option Explicit
Sub test()
  Dim all As Long
  Dim i As Long, z As Long, z2 As Long, z_max As Long
  all = Sheets("All").Index
  z2 = Sheets(all).Range("A" & Rows.Count).End(xlUp).Row + 1
  
  For i = Sheets.Count To 1 Step -1
   If Sheets(i).Name <> "Menu" And Sheets(i).Name <> "All" Then
     With Sheets(i)
       z_max = .Range("N" & Rows.Count).End(xlUp).Row
       For z = 1 To z_max
         If .Range("N" & z).Value >= 100 Then
           .Range("N" & z).Interior.Color = vbBlue
           Sheets(all).Range("A" & z2 & ":A" & z2 + 4).Value = _
           .Range("N" & z).Offset(1).Resize(5).Value
           .Range("N" & z).Offset(1).Resize(5).Interior.Color = vbYellow
           z = z + 6
           .Range("N" & z).Interior.Color = vbRed
           z2 = z2 + 5
         End If
       Next z
     End With
   End If
  Next i
End Sub
Dabei durchsuche ich nicht nur nicht "Menu", sondern auch nicht "All".
Die diversen Einfärbungen kannst du ja wieder rausnehmen, ich wollte nur visuell nachvollziehen, was passiert.
Die Datei: https://www.herber.de/bbs/user/97991.xls
Happy Exceling,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Werte aus Sheets kopieren "