Isoler dans un autre classeur toutes les cellules rouge

Bonjour

Jai une macro qui a partir de l'année d'une date saisi me colorie en rouge toutes les cellules dans lesquelles cette année apparait

je souhaiterais isoler dans une autre feuille toutes les cellules en rouge

merci

voici le code de ma macro et le fichier correspondant

Sub date_2()

Dim X As Variant

Dim Cel As Range

X = Application.InputBox("Année de la date", "ANNÉE", Type:=1)

If X = False Then Exit Sub

Set Cel = Sheets("Feuil1").UsedRange.Find(X, lookat:=xlPart)

If Not Cel Is Nothing Then

PA = Cel.Address

Do

Cel.Interior.ColorIndex = 3

Set Cel = Sheets("Feuil1").UsedRange.FindNext(Cel)

Loop While Not Cel Is Nothing And Cel.Address <> PA

End If

End Sub

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Bonjour GMB,

Je n'arrive pas a avoir accès au code de ta macro pourrais-tu l'envoyer a part stp ?

Il s'agit d'une adaptation de ton propre code.

Tu peux la voir en tapant simultanément sur les touches Alt et F11

Bye !

Option Explicit
Sub date_2()
    Dim X As Variant, PA$
    Dim Cel As Range, tablor(), k&, lgn&
    Dim f As Worksheet, fe As Worksheet

    Set f = ActiveSheet
    Sheets.Add after:=ActiveSheet
    Set fe = ActiveSheet
    fe.Range("A1").CurrentRegion.Offset(1, 0).Clear
    X = Application.InputBox("Année de la date", "ANNÉE", Type:=1)
    If X = False Then Exit Sub
    Set Cel = f.UsedRange.Find(X, lookat:=xlPart)
    If Not Cel Is Nothing Then
         PA = Cel.Address
         Do
            Cel.Interior.ColorIndex = 3
            lgn = fe.Range("A" & Rows.Count).End(xlUp)(2).Row
            f.Rows(Cel.Row & ":" & Cel.Row).Copy fe.Range("A" & lgn)

            Set Cel = f.UsedRange.FindNext(Cel)
         Loop While Not Cel Is Nothing And Cel.Address <> PA
    End If
    fe.Activate
End Sub

merciii beaucoup c'est exactement ce que je voulais