Discussion :

[lleirce]

Bonjour,

Je souhaiterais votre aide sur le code de la macro que j'ai écris.

Je voudrais copier/coller une ligne de l'onglet JANVIER2015 en fonction de la couleur de la case de la colonne M à partir de la case M3 dans l'onglet "plislivres" ou dans l'onglet "plislivresretard". J'utilise deux couleurs le gris (191, 191, 191) dans l'onglet "plislivresretard" et le vert (146, 208, 80) dans l'onglet "plislivres".
Après cette copie dans l'un ou l'autre onglet, la ligne copiée doit disparaitre de l'onglet "JANVIER2015"

Ci dessous mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub CommandButton22_Click()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (DESTination)
 
With Sheets("JANVIER2015") 'prend en compte l'onglet "JANVIER2015"
    For Each cel In .Range("M3:M" & .Range("M65536").End(xlUp).Row) 'boucle sur toutes les cellules éditées de la colonne M
        If cel.Interior.Color = RGB(191, 191, 191) Then Set dest = Sheets("Plislivresretard").Range("A65536").End(xlUp).Offset(1, 0) 'définit la variable dest
                Range(Cells(cel.Row, 1), cel).Copy dest 'copie et colle la ligne
    Next cel
    For Each cel In .Range("M3:M" & .Range("M65536").End(xlUp).Row) 'boucle sur toutes les cellules éditées de la colonne M
        If cel.Interior.Color = RGB(146, 208, 80) Then Set dest = Sheets("Plislivres").Range("A65536").End(xlUp).Offset(1, 0) 'définit la variable dest
                Range(Cells(cel.Row, 1), cel).Copy dest 'copie et colle la ligne
    Next cel
End With
End Sub

Pièce jointe 168509

Je ne sais pas si mon code est bon et il plate systématiquement lorsque je veux le copier/coller.

Je mets en pièce jointe mon fichier pour que vous vous rendiez mieux compte.

Merci de votre aide.

[Thautheme]

Bonsoir Lleirce, bonsoir le forum,

Peut-être comme ça, avec une seule boucle :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub CommandButton22_Click()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (DESTination)
 
With Sheets("JANVIER2015") 'prend en compte l'onglet "JANVIER2015"
    For Each cel In .Range("M3:M" & .Range("M65536").End(xlUp).Row) 'boucle sur toutes les cellules éditées de la colonne M
        If cel.Interior.Color = RGB(191, 191, 191) Then
            Set dest = Sheets("Plislivresretard").Range("A65536").End(xlUp).Offset(1, 0) 'définit la variable dest
            .Range(Cells(cel.Row, 1), cel).Copy dest 'copie et colle la ligne
        End If
        If cel.Interior.Color = RGB(146, 208, 80) Then
            Set dest = Sheets("Plislivres").Range("A65536").End(xlUp).Offset(1, 0) 'définit la variable dest
            .Range(Cells(cel.Row, 1), cel).Copy dest 'copie et colle la ligne
        End If
    Next cel
End With
End Sub

[lleirce]

Bonsoir Tautheme,

Merci pour ta réponse si rapide.
Ta correction fonctionne, mais il y a deux problèmes:
- seules deux lignes ont bien été copiées et transférées sur les onglets,
- les deux lignes en question n'ont pas été supprimées de l'onglet source.

Et j'avoue que je ne comprends pas.

Lleirce

[geogeo70]

Et j'avoue que je ne comprends pas.

Lleirce

bonsoir,

Pendant que thautheme t'envoyait une solution je travaillais sur ton fichier, comme lui j'y ai vu une erreur les blocs"if then endif". d'autre part lorsque les cas sont différents autant utiliser select case sur une seule itération (ça gagne du temps)
J'ai également défini la longueur exacte de la copie et règlé quelques index...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub CommandButton22_Click()
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (DESTination)
 
With Sheets("JANVIER2015") 'prend en compte l'onglet "JANVIER2015"
    For Each cel In .Range("M3:M" & .Range("M65536").End(xlUp).Row) 'boucle sur toutes les cellules éditées de la colonne M
        Select Case cel.Interior.Color
            Case RGB(191, 191, 191)
                Set dest = Sheets("Plislivresretard").Range("M65536").End(xlUp).Offset(1, -12) 'définit la variable dest
                .Range(.Cells(cel.Row, 1), .Cells(cel.Row, cel.Offset(0, 10000).End(xlToLeft).Column)).Copy Destination:=dest 'copie et colle la ligne
            Case RGB(146, 208, 80)
                Set dest = Sheets("Plislivres").Range("M65536").End(xlUp).Offset(1, -12) 'définit la variable dest
                .Range(.Cells(cel.Row, 1), .Cells(cel.Row, cel.Offset(0, 10000).End(xlToLeft).Column)).Copy Destination:=dest 'copie et colle la ligne
        End Select
    Next cel
End With
End Sub

Je n'ai pas supprimé les lignes aprés la copie, c'est possible mais dans ce cas il faudrait savoir si c'est le contenu ou la ligne. Si c'est le contenu utilise "Clear" sinon il faut revoir la boucle et utiliser un tant que... en variant le n° de ligne par exemple

je joins le fichier :

Suivi transporteurcor.xlsm

a++
geogeo70

[Thautheme]

Bonsoir le fil, bonsoir le forum,

c'est marrant mais je connais ce code...

Le problème vient du fait que ta variable dest est définie par rapport à la colonne A et que, dans ton exemple, les lignes copiées/collées ne contiennent pas de valeur en colonne A. Donc, chaque nouvelle ligne écrasait l'ancienne et a la fin tu navet (oui dans ce cas on peut...) qu'une seule ligne de chaque couleur... GéoGéo a corrigé ce beug avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set dest = Sheets("Plislivresretard").Range("M65536").End(xlUp).Offset(1, -12) 'définit la variable dest

Je te propose un nouvelle méthode un peu plus rapide :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Sub CommandButton22_Click()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TLV As Range 'déclare la variable TLV (Tableau des Ligne Vertes)
Dim TLG As Range 'déclare la variable TLG (Tableau des Ligne Grises)
Dim LI As Integer 'déclare la variable LI (LIgne)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("JANVIER2015") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 13).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 13 de l'onglet O
Set TLV = O.Range("A1") 'initialise la plage TLV
Set TLG = O.Range("A1") 'initialise la plage TLG
For LI = 3 To DL 'boucle sur toutes les lignes de 3 à DL
    'condition : si la couleur de la cellule ligne LI, colonne 13 est grise
    If O.Cells(LI, 13).Interior.Color = RGB(191, 191, 191) Then
        'redéfinit la plage TLG (la ligne LI si TLG ne comporte qu'une seule cellule,
        'sinon, l'union de TLG et de la ligne LI)
        Set TLG = IIf(TLG.Cells.Count = 1, Rows(LI), Application.Union(TLG, Rows(LI)))
    End If 'fin de la condition
    'condition : si la couleur de la cellule ligne LI, colonne 13 est verte
    If O.Cells(LI, 13).Interior.Color = RGB(146, 208, 80) Then
        'redéfinit la plage TLV (la ligne LI si TLV ne comporte qu'une seule cellule,
        'sinon, l'union de TLV et de la ligne LI)
        Set TLV = IIf(TLV.Cells.Count = 1, Rows(LI), Application.Union(TLV, Rows(LI)))
    End If 'fin de la condition
Next LI 'prochaine ligne de la boucle
TLG.Copy Sheets("Plislivresretard").Range("A2") 'copie et colle la plage TLG dans la cellule A2 de l'onglet "Plislivresretard"
TLG.Delete 'supprime la plage TLG
TLV.Copy Sheets("Plislivres").Range("A2") 'copie et colle la plage TLV dans la cellule A2 de l'onglet "Plislivres"
TLV.Delete 'supprime la plage TLV
Application.ScreenUpdating = True 'Affiche les rafraîchissements d'écran
End Sub

[lleirce]

Un grand merci à tous pour votre aide et pour votre rapidité.
Tautheme, j'ai utilisé ton code et je l'ai modifié pour que les lignes copiées vers les onglets "Plislivres" et "Plislivresretard" soient copiées après la dernière ligne pleine.
Le problème c'est que la copie se fait systématiquement en ligne A2 et écrase le contenu de cette ligne.
Comment faire pour que les lignes copiées le soient en dernière ligne ?
Voila les modifications que j'ai apporté à ton code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Sub CommandButton22_Click()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TLV As Range 'déclare la variable TLV (Tableau des Ligne Vertes)
Dim TLG As Range 'déclare la variable TLG (Tableau des Ligne Grises)
Dim LI As Integer 'déclare la variable LI (LIgne)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("JANVIER2015") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 13).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 13 de l'onglet O
Set TLV = O.Range("A1") 'initialise la plage TLV
Set TLG = O.Range("A1") 'initialise la plage TLG
For LI = 3 To DL 'boucle sur toutes les lignes de 3 à DL
    'condition : si la couleur de la cellule ligne LI, colonne 13 est grise
    If O.Cells(LI, 13).Interior.Color = RGB(191, 191, 191) Then
        'redéfinit la plage TLG (la ligne LI si TLG ne comporte qu'une seule cellule,
        'sinon, l'union de TLG et de la ligne LI)
        Set TLG = IIf(TLG.Cells.Count = 1, Rows(LI), Application.Union(TLG, Rows(LI)))
    End If 'fin de la condition
    'condition : si la couleur de la cellule ligne LI, colonne 13 est verte
    If O.Cells(LI, 13).Interior.Color = RGB(146, 208, 80) Then
        'redéfinit la plage TLV (la ligne LI si TLV ne comporte qu'une seule cellule,
        'sinon, l'union de TLV et de la ligne LI)
        Set TLV = IIf(TLV.Cells.Count = 1, Rows(LI), Application.Union(TLV, Rows(LI)))
    End If 'fin de la condition
Next LI 'prochaine ligne de la boucle
TLG.Copy Sheets("Plislivresretard").Range("A" & Rows.Count).End(xlUp) 'copie et colle la plage TLG dans la cellule A2 de l'onglet "Plislivresretard"
TLG.Delete 'supprime la plage TLG
TLV.Copy Sheets("Plislivres").Range("A" & Rows.Count).End(xlUp) 'copie et colle la plage TLV dans la cellule A2 de l'onglet "Plislivres"
TLV.Delete 'supprime la plage TLV
Application.ScreenUpdating = True 'Affiche les rafraîchissements d'écran
End Sub

En rouge les modifications que j'ai apporté.