Copier une cellule si elle est colorée

Bonjour,

J'ai essayé de developper une macro qui me copie les cellules en jaune dans une nouvelle feuille excel mais il me semble que j'ai oublié quelques astuces dans mon script.

Sub parametre()

With Worksheets("Budgets_Uniques_modifié")

j = 2

For i = 1 To 9000

If Cells(1, i) = "x" Then

If .Cells(j, i).Interior.ColorIndex = 6 Then

Worksheets("feuil1").Cells(j, 1) = .Cells(i, 3)

Worksheets("feuil1").Cells(j, 2) = .Cells(i, 4)

j = j + 1

End If

End If

Next i

End With

End Sub

Je mets aussi mon fichier de test dans la discussion

Merci beaucoup pour vos retours

Bonjour Kent, bonjour le forum,

Il semblerait que tu te sois mélangé les pinceaux entre ligne et colonnes... J'aurais codé comme ça :

Sub parametre()
Dim OS As Worksheet
Dim OD As Worksheet
Dim DL As Long
Dim I As Long

Set OS = Worksheets("Budgets_Uniques_modifié")
Set OD = Worksheets("Feuil1")
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp)
J = 2
For I = 3 To DL
    If OS.Cells(I, 6).Interior.ColorIndex = 6 Then
        OD.Cells(J, 1).Value = OS.Cells(I, 3).Value
        OD.Cells(J, 2).Value = OS.Cells(I, 4).Value
        J = J + 1
    End If
Next I
End Sub

c'est top!

En fait, ce qui conditionne mon copiage c'est le x qui est à la 1ere ligne et aussi la couleur jaune de la colonne.

Je voulais faire aussi c'est de copier le nom de la colonne pour tout le resultat dans la 3eme colonne du feuil2 je fais comment pour passer à mon 2eme "x" dans la 1ere ligne?

Re,

Ha d'accord !... Je navet pas compris. Essaie ça :

Sub parametre()
Dim OS As Worksheet
Dim OD As Worksheet
Dim DL As Long
Dim DC As Byte
Dim I As Long
Dim J As Byte
Dim K As Byte

Set OS = Worksheets("Budgets_Uniques_modifié")
Set OD = Worksheets("Feuil1")
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp)
DC = OS.Cells(1, Application.Columns.Count).End(xlToLeft).Column

K = 2
For J = 3 To DC
    If OS.Cells(1, J).Value = "x" Then
        For I = 3 To DL
            If OS.Cells(I, 6).Interior.ColorIndex = 6 Then
                OD.Cells(K, 1).Value = OS.Cells(I, 3).Value
                OD.Cells(K, 2).Value = OS.Cells(I, 4).Value
                K = K + 1
            End If
        Next I
    End If
Next J
End Sub

Merci beaucoup pour votre script! mais je n'arrive pas toujours à trouver ce que je souhaite.

Dans le fichier que je mets en joint, j'ai mis manuellement en feuil1 le resultat souhaité. Je suis perdu

Re,

En effet, il y avait une erreur dans le code le voici corrigé :

Sub parametre()
Dim OS As Worksheet
Dim OD As Worksheet
Dim DL As Long
Dim DC As Byte
Dim I As Long
Dim J As Byte
Dim K As Byte

Set OS = Worksheets("Budgets_Uniques_modifié")
Set OD = Worksheets("Feuil1")
DL = OS.Cells(Application.Rows.Count, "A").End(xlUp)
DC = OS.Cells(1, Application.Columns.Count).End(xlToLeft).Column

K = 2
For J = 3 To DC
    If OS.Cells(1, J).Value = "x" Then
        For I = 3 To DL
            If OS.Cells(I, J).Interior.ColorIndex = 6 Then
                OD.Cells(K, 1).Value = OS.Cells(I, 3).Value
                OD.Cells(K, 2).Value = OS.Cells(I, 4).Value
                K = K + 1
            End If
        Next I
    End If
Next J
End Sub