Vba Excel : Importer Cellule colorer Feuille
Andreaa
-
eriiic Messages postés 25847 Date d'inscription Statut Contributeur Dernière intervention -
eriiic Messages postés 25847 Date d'inscription Statut Contributeur Dernière intervention -
Bonjour,
Voila je possede de feuille Feuille 1 et Feuille 2.
J'aimerai en fait que ma macro me colle sur la Feuille 2 toutes les lignes de la Feuille 1 dont la collone X est rouge.
Voici mon code :
----------
Sub FILTRE()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("Feuille2").Activate ' feuille de destination
Col = "X"
NumLig = 2
With Sheets("Feuille1")
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 3 To NbrLig
If .Cells(Lig, Col).Interior.Color = vbRed Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("Feuille2").Cells(NumLig, 1).Insert Shift:=xlDown
End If
Next
End With
----------
Le script marche, mais il copie toutes les lignes....
Une idee de l'erreur ?
Voila je possede de feuille Feuille 1 et Feuille 2.
J'aimerai en fait que ma macro me colle sur la Feuille 2 toutes les lignes de la Feuille 1 dont la collone X est rouge.
Voici mon code :
----------
Sub FILTRE()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("Feuille2").Activate ' feuille de destination
Col = "X"
NumLig = 2
With Sheets("Feuille1")
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 3 To NbrLig
If .Cells(Lig, Col).Interior.Color = vbRed Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("Feuille2").Cells(NumLig, 1).Insert Shift:=xlDown
End If
Next
End With
----------
Le script marche, mais il copie toutes les lignes....
Une idee de l'erreur ?
A voir également:
- Vba Excel : Importer Cellule colorer Feuille
- Liste déroulante excel - Guide
- Word et excel gratuit - Guide
- Si ou excel - Guide
- Excel compter cellule couleur sans vba - Guide
- Déplacer colonne excel - Guide
3 réponses
J'ai change la formule, mais j'ai le meme resultat
Voici le changement :
Sub FiltreLuLu()
Dim Lig As Long
Dim Col As Integer
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEST").Activate ' feuille de destination
Col = 32 ' colonne données non vides à tester - AF'
NumLig = 2 'N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ? '
With Sheets("QUOTE AND PO TRACKING") ' feuille source'
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 3 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Interior.Color = RGB(255, 0, 0) Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("TEST").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next
End With
End Sub
Voici le changement :
Sub FiltreLuLu()
Dim Lig As Long
Dim Col As Integer
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEST").Activate ' feuille de destination
Col = 32 ' colonne données non vides à tester - AF'
NumLig = 2 'N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ? '
With Sheets("QUOTE AND PO TRACKING") ' feuille source'
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 3 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Interior.Color = RGB(255, 0, 0) Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("TEST").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next
End With
End Sub
