Aide pour macro copie de ligne

[O2b]

Bonjour,

J'ai besoin d'une aide précieuse de votre part. Voila, j'ai programmé une macro pour colorier des lignes de différentes couleurs suivant un bouton. je souhaiterais maintenant que ces lignes colorées se recopient automatiquement dans des autres feuilles du même classeur.
Respectivement les lignes de couleurs vertes recopiées dans une feuille"Préventif", les lignes rouges dans une feuille"Correctif" et les lignes jaunes dans une feuille"HC"

Voila ma macro de la mise en couleur des lignes:

Sub Bouton1_Clic()
Dim c As Range, cellule As Range
Dim lig As Byte

Application.ScreenUpdating = False
For Each c In ActiveSheet.Range("i1:i200")
c = UCase(c)
lig = c.Row
Set cellule = Range(Cells(lig, 1), Cells(lig, 9))
Select Case c
Case "P"
cellule.Interior.ColorIndex = 4
Case "C"
cellule.Interior.ColorIndex = 3
Case "HC"
cellule.Interior.ColorIndex = 6
Case ""
cellule.Interior.ColorIndex = -4142
End Select
Next
End Sub

J'espère que je suis assez clair dans ma galère....

Cordialement,

O2b

 

[Cousinhub]

Re : Aide pour macro copie de ligne

Bonjour,

en repartant de ton code, et en y ajoutant un filtre élaboré, regarde le fichier exemple :

Le code :

Sub Bouton1_Clic()
Dim Cel As Range, cellule As Range
Dim Lig As Integer, Sh As Worksheet, Crit As String
Application.ScreenUpdating = False
With Sheets("données")
    .Range("A1:I" & .[A65000].End(xlUp).Row).Name = "base"
    For Each Cel In .Range("I2:I" & .[A65000].End(xlUp).Row)
        Cel = UCase(Cel)
        Lig = Cel.Row
        Set cellule = .Range(.Cells(Lig, 1), .Cells(Lig, 9))
        Select Case Cel
            Case "P"
                cellule.Interior.ColorIndex = 4
            Case "C"
                cellule.Interior.ColorIndex = 3
            Case "HC"
                cellule.Interior.ColorIndex = 6
            Case ""
                cellule.Interior.ColorIndex = -4142
        End Select
    Next Cel
End With
For Each Sh In Sheets
    If Sh.Name <> "données" Then
        With Sh
            .Cells.Interior.ColorIndex = -4142
            Crit = Left(Sh.Name, 1)
            .[K1] = "titre9": .[K2] = Crit
            Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range( _
                "K1:K2"), CopyToRange:=.Range("A1:I1"), Unique:=False
            .[K1:K2].ClearContents
        End With
    End If
Next Sh
End Sub

Le fichier :

 

[kjin]

Re : Aide pour macro copie de ligne

Bonjour,

... je souhaiterais maintenant que ces lignes colorées se recopient automatiquement dans des autres feuilles du même classeur.

N'importe où dans la feuille en question !?
A+
kjin

 

[Denis]

Re : Aide pour macro copie de ligne

Bonjour kjin, bhbh et le forum
bhbh, pourquoi ne pas mettre le copier/coller dans le select case (désolé pas le temps de l'essayer moi-même). Je pense que l'on devrait gagner en vitesse
Bon courage et à +
Denis

 

[Cousinhub]

Re : Aide pour macro copie de ligne

Bonjour,

Denis, je pense qu'un filtre élaboré est bien plus rapide que des copier/Coller

Pour un copier/coller, il te faut à chaque fois calculer la ligne de destination, copier puis coller

Avec un filtre élaboré, uniquement 3 calculs...

Calcul effectué sur 2160 lignes

Avec mon code : 0.79 seconde

avec le code que tu envisages : 5.46 secondes

Le code :

Sub Bouton1_Clic()
t = Timer
Dim Cel As Range, cellule As Range
Dim Lig As Integer, Sh As Worksheet, Crit As String
Application.ScreenUpdating = False
With Sheets("données")
    .Range("A1:I" & .[A65000].End(xlUp).Row).Name = "base"
    For Each Cel In .Range("I2:I" & .[A65000].End(xlUp).Row)
        Cel = UCase(Cel)
        Lig = Cel.Row
        Set cellule = .Range(.Cells(Lig, 1), .Cells(Lig, 9))
        Select Case Cel
            Case "P"
                cellule.Interior.ColorIndex = 4
                With Sheets("Préventif")
                    derlig = .[A65000].End(xlUp).Row + 1
                    cellule.Copy .Cells(derlig, 1)
                End With
            Case "C"
                cellule.Interior.ColorIndex = 3
                With Sheets("Correctif")
                    derlig = .[A65000].End(xlUp).Row + 1
                    cellule.Copy .Cells(derlig, 1)
                End With

            Case "HC"
                cellule.Interior.ColorIndex = 6
                With Sheets("HC")
                    derlig = .[A65000].End(xlUp).Row + 1
                    cellule.Copy .Cells(derlig, 1)
                End With
            Case ""
                cellule.Interior.ColorIndex = -4142
        End Select
    Next Cel
End With
MsgBox Timer - t
End Sub