[XL-2002] Copier Ligne dans une autre Feuil Suivant Condition

[vaucluseimmo]

Bonsoir
Dans le Fichier joint dans la Feuil "Base"
Je DbleClique dans Col D ça affiche un X Col D,et Copy Ligne dans feuil "ProduitsAchetés" Col A,B,C,la OK ça fonctionne

Si je DbleClique a nouveau dans cette Col D ,ça éfface le X et ça éfface,la ligne Copiées dans la Feuil "ProduitsAchetés" , la Ok ça fonctionne

ce qu'il me faut a ce stade,c'est de Colorier en Jaune, les Cellules ou sont copiées les Données,et d’effacer aussi la Couleur,si je DbleClique a nouveau

Ensuite
Il me faut la même chose,mais pour agir dans la Col F et Copier dans feuil
"ProduitsAchetés",avec Couleur Vert

Merci pour votre aide

Cordialement

----------------------------------------------------------------------------
Fichier joint dans vos discussions
------------------------------------------------------------------------------

[Qwazerty]

Salut
Ne serait il pas possible de faire la coloration à l'aide d'une Mise En Forme conditionnelle?
++
Qwaz

[vaucluseimmo]

Bonjour Qwazerty

Peu importe la façon de faire, du moment
ou ça fonctionne comme je le souhaite

Cordialement

[Qwazerty]

Salut
Je te laisse donc te renseigner sur les MFC et nous revenir en cas de besoin.
++
Qwaz

[vaucluseimmo]

Bonsoir
Je connais un peu les MFC mais pour ce que je cherche a réaliser, je vois pas comment faire

Bonne soirée

[Qwazerty]

Salut

Peut-être en tenant compte de la valeur de la colonne D?
Si tu as un X tu mets en jaune, si tu n'en a pas ça reste incolore.

Et si ceux sont les lignes copiées dans l'autre feuille qui doivent être passé en jaune, il serait bien de montrer le code que tu utilises pour faire le transfère, le forfait de ma boule de cristal est épuisé ce mois-ci

++
Qwaz

[vaucluseimmo]

Bonjour Qwarserty

Voici le code,puisque le modérateur a viré ma piéce jointe

Code :

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
33
34
35
Private Sub Worksheet_BeforeDoubleClick(ByVal cel As Range, Cancel As Boolean)
If Intersect(cel, [D2:D65536]) Is Nothing Then Exit Sub
Cancel = True
Application.EnableEvents = False 'évite la relance de la macro par les modifs qu'elle fait
If Intersect(cel, [D:E]).Cells.Count > 1000 Then _
MsgBox "Sélection trop grande.": Application.Undo: GoTo 1 'limitation de la sélection
On Error Resume Next
For Each cel In Intersect(cel, [D2:D65536]) 'traite toutes les cellules sélectionnées colonne F
 
If Application.CountA([A1:C1].Offset(cel.Row - 1)) < 3 Then _
cel.Value = "" 'si ligne incomplète aucun transfert
If cel <> "" Then 'si x existe
cel = ""
cel.Offset(0, 1).Value = "" 'effacement repère colonne G
If cel.Interior.ColorIndex > 0 Then Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 0 'effacement couleur
Sheets("ProduitsAcheter").Rows(Application.Match(0, _
Sheets("ProduitsAcheter").Range("D:D"), 0)).Delete 'suppression de la ligne en feuille "AA" si repère = 0
Else 'si aucun x
cel.Value = "X"
If cel.Offset(0, 1) <> 1 Then
cel.Offset(0, 1).Value = 1 'repère colonne G
Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 36 'mise en couleur
With Sheets("ProduitsAcheter").Range("A65536").End(xlUp)  'dernière cellule colonne A
.Offset(1).FormulaR1C1 = "=Base!R" & cel.Row & "C1" 'transfert nom
.Offset(1, 1).FormulaR1C1 = "=Base!R" & cel.Row & "C2" 'transfert prénom"
.Offset(1, 2).FormulaR1C1 = "=Base!R" & cel.Row & "C3" 'transfert n°dossier"
'''.Offset(1, 5).Value = Now 'date/heure du transfert"
.Offset(1, 3).FormulaR1C1 = "=Base!R" & cel.Row & "C5" 'repère colonne E
Sheets("ProduitsAcheter").Range("A2:C65536").Sort Key1:=Sheets("ProduitsAcheter").Range("A1"), Order1:=xlAscending 'tri croissant
End With
End If
End If
Next
1 Application.EnableEvents = True
End Sub

Dans l'attente de te lire,
Cordialement

[Qwazerty]

Salut
Voila déjà ton code présenté pour qu'il soit lisible.
Je ne comprend toujours pas ce que tu veux colorer, c'est surement limpide à tes yeux, mais prend le temps de nous expliquer.

Code :

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
33
34
35
36
37
38
39
40
41
42
43
44
Option Explicit
 
Private Sub Worksheet_BeforeDoubleClick(ByVal cel As Range, Cancel As Boolean)
    If Intersect(cel, [D2:D65536]) Is Nothing Then Exit Sub
    Cancel = True
    Application.EnableEvents = False 'évite la relance de la macro par les modifs qu'elle fait
 
    If Intersect(cel, [D:E]).Cells.Count > 1000 Then
        MsgBox "Sélection trop grande."
        Application.Undo
        Exit Sub
        'GoTo 1 'limitation de la sélection
    End If
 
    On Error Resume Next
    For Each cel In Intersect(cel, [D2:D65536]) 'traite toutes les cellules sélectionnées colonne F
 
        If Application.CountA([A1:C1].Offset(cel.Row - 1)) < 3 Then cel.Value = "" 'si ligne incomplète aucun transfert
        If cel <> "" Then 'si x existe
            cel = ""
            cel.Offset(0, 1).Value = "" 'effacement repère colonne G
            If cel.Interior.ColorIndex > 0 Then Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 0 'effacement couleur
            Sheets("ProduitsAcheter").Rows(Application.Match(0, Sheets("ProduitsAcheter").Range("D:D"), 0)).Delete 'suppression de la ligne en feuille "AA" si repère = 0
        Else 'si aucun x
            cel.Value = "X"
            If cel.Offset(0, 1) <> 1 Then
                cel.Offset(0, 1).Value = 1 'repère colonne G
                Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 36 'mise en couleur
                With Sheets("ProduitsAcheter").Cells(Rows.Count, "A").End(xlUp) 'dernière cellule colonne A
                    .Offset(1).FormulaR1C1 = "=Base!R" & cel.Row & "C1" 'transfert nom
                    .Offset(1, 1).FormulaR1C1 = "=Base!R" & cel.Row & "C2" 'transfert prénom"
                    .Offset(1, 2).FormulaR1C1 = "=Base!R" & cel.Row & "C3" 'transfert n°dossier"
                    '''.Offset(1, 5).Value = Now 'date/heure du transfert"
                    .Offset(1, 3).FormulaR1C1 = "=Base!R" & cel.Row & "C5" 'repère colonne E
                End With
                With Sheets("ProduitsAcheter")
                    .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("A1"), Order1:=xlAscending 'tri croissant
                End With
            End If
        End If
    Next
'1
Application.EnableEvents = True
End Sub

J'en ai profité pour modifier 2/3 choses.

++
Qwaz

[vaucluseimmo]

Bonjour

Mes explications, sont notée dans ce fil dans mon premier message

ce n'est pas assez explicite???

a +++++++++++++++

[Qwazerty]

Code :

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
33
34
35
36
37
38
39
40
41
Private Sub Worksheet_BeforeDoubleClick(ByVal cel As Range, Cancel As Boolean)
    If Intersect(cel, [D2:D65536]) Is Nothing Then Exit Sub
    Cancel = True
    Application.EnableEvents = False 'évite la relance de la macro par les modifs qu'elle fait
 
    If Intersect(cel, [D:E]).Cells.Count > 1000 Then
        MsgBox "Sélection trop grande."
        Application.Undo
        Exit Sub
        'GoTo 1 'limitation de la sélection
    End If
 
    On Error Resume Next
    For Each cel In Intersect(cel, [D2:D65536]) 'traite toutes les cellules sélectionnées colonne F
        With ThisWorkbook.Sheets("ProduitsAcheter")
            If Application.CountA([A1:C1].Offset(cel.Row - 1)) < 3 Then cel.Value = "" 'si ligne incomplète aucun transfert
            If cel <> "" Then 'si x existe
                cel = ""
                cel.Offset(0, 1).Value = "" 'effacement repère colonne G
                If cel.Interior.ColorIndex > 0 Then .Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 0 'effacement couleur
                .Rows(Application.Match(0, .Range("D:D"), 0)).Delete 'suppression de la ligne en feuille "AA" si repère = 0
            Else 'si aucun x
                cel.Value = "X"
                If cel.Offset(0, 1) <> 1 Then
                    cel.Offset(0, 1).Value = 1 'repère colonne G
                    .Range(cel.Offset(0, -3), cel).Interior.ColorIndex = 36 'mise en couleur
                    With .Cells(Rows.Count, "A").End(xlUp) 'dernière cellule colonne A
                        .Offset(1).FormulaR1C1 = "=Base!R" & cel.Row & "C1" 'transfert nom
                        .Offset(1, 1).FormulaR1C1 = "=Base!R" & cel.Row & "C2" 'transfert prénom"
                        .Offset(1, 2).FormulaR1C1 = "=Base!R" & cel.Row & "C3" 'transfert n°dossier"
                        '''.Offset(1, 5).Value = Now 'date/heure du transfert"
                        .Offset(1, 3).FormulaR1C1 = "=Base!R" & cel.Row & "C5" 'repère colonne E
                    End With
                    .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("A1"), Order1:=xlAscending 'tri croissant
                End If
            End If
        End With
    Next
'1
Application.EnableEvents = True
End Sub

Comme je le comprend, il manquait juste les "." au début des lignes qui modifie la couleur.

Code :

.Range(cel.Offset(0, -3), cel).Interior.ColorIndex

Si ça n'est pas ça... désolé je ne comprend pas...

++
Qwaz