Autres Recopie valeurs si (VBA)

[ALEA()]

Bonjour le forum, les confinés......comme moi!

Je voudrais inclure une recopie de cellules en VBA mais je n'y arrive pas pour la détection du nb en rouge et la copie à la suite (voir fichier joint).

Si vous pouvez m'y aider...je vous enverrai un peu de gel et un masque.....

A++
Alea()

 

[Staple1600]

Bonsoir le fil, ALEA()

•>ALEA()

Sub Jelly_Mask()
Dim anche As Long, i As Long, j As Long
anche = Cells(Rows.Count, "F").End(3).Row
For i = 1 To anche
If Cells(i, "F").Font.Color = vbRed Then
Cells(Rows.Count, "Q").End(3).Offset(j).Resize(, 5) = Cells(i, "A").Resize(, 5).Value
j = j + 1
End If
Next
End Sub

Combien de litres de gel, tu m'envoies ?

 

[ALEA()]

Bonjour et merci Staple, je vais me baser sur ton code. Peux-tu m'aider à extraire et copier à côté une ligne sur 2? Je joins un exemple et résultat feuille 2, c'est pas simple manuellement, j'ai environ 500 lignes........
Merci
du gel Pastagais???????

 

[Staple1600]

Re

Si j'ai bien compris le truc

Sub Bazinga()
Dim P As Range, c As Range, Rng As Range, f As Worksheet, ff As Worksheet
Set f = ActiveSheet: Set ff = Sheets("Feuil2")
Set P = f.Range(f.Cells(1, "F"), f.Cells(Rows.Count, "F").End(3))
For Each c In P
Set Rng = f.Cells(c.Row, "A").Resize(, 5)
Select Case c
Case Is = "reste"
ff.Cells(Rows.Count, "A").End(3)(2).Resize(, 5) = Rng.Value
Case Is = "à sortir"
ff.Cells(Rows.Count, "G").End(3)(2).Resize(, 5) = Rng.Value
End Select
Set Rng = Nothing
Next c
ff.Rows(1).Delete
End Sub

NB: Le code doit être lancé quand c'est la feuille 1 qui est active.

 

[ALEA()]

Bonjour, merci beaucoup.
a bientôt