Agregation de 2 codes ; Problème!

[anthoYS]

Bonjour ;

Voilà le code principal :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
With Target
    If .Column = 2 Then
        Cancel = True
        If .Comment Is Nothing Then
            .AddComment
            .Comment.Shape.Width = 121.5
            .Comment.Shape.Height = 29.75
        End If
        SendKeys "%im"
    End If
    If Target.Column = 4 Then
Cells(Target.Row, 4) = Date
End If
End With
End Sub

Je veux ajouter ceci :

[COLOR="DarkOrchid"]Dim c As Long, i As Long
If Intersect(Target, Union([klj], [infinite])) Is Nothing Then Exit Sub
    c = Target.Interior.ColorIndex
    For i = 1 To Range("couple").Count
        If Range("couple").Cells(i, 1).Interior.ColorIndex = c Then
            Target.Interior.ColorIndex = Range("couple").Cells(i + 1, 1).Interior.ColorIndex
            Target.Font.ColorIndex = Range("couple").Cells(i + 1, 1).Font.ColorIndex
            i = Range("couple").Count
            Cancel = True
             End If
    Next i[/COLOR]

Mais ou le placer pour que ça fonctionne?

Merci

 

[anthoYS]

Re : Agregation de 2 codes ; Problème!

Re,

J'ai mis ensemble les codes ainsi :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
[COLOR="DarkOrchid"]Dim c As Long, i As Long[/COLOR]
Cancel = True
With Target
    If .Column = 2 Then
        Cancel = True
        If .Comment Is Nothing Then
            .AddComment
            .Comment.Shape.Width = 121.5
            .Comment.Shape.Height = 29.75
        End If
        SendKeys "%im"
    End If
    If Target.Column = 4 Then
Cells(Target.Row, 4) = Date
End If
End With
[COLOR="#9932cc"]If Intersect(Target, Union([klj], [infinite])) Is Nothing Then Exit Sub
    c = Target.Interior.ColorIndex
    For i = 1 To Range("couple").Count
        If Range("couple").Cells(i, 1).Interior.ColorIndex = c Then
            Target.Interior.ColorIndex = Range("couple").Cells(i + 1, 1).Interior.ColorIndex
            Target.Font.ColorIndex = Range("couple").Cells(i + 1, 1).Font.ColorIndex
            i = Range("couple").Count
            Cancel = True
             End If
    Next i[/COLOR]
End Sub

La sub() sur le commentaire à ajouter par double clic fonctionne, mais pas la coloration en dégradé de la sorte.

Car voici ce que ça fait lors des doubles clics sur une cellule de la plage "infinite", rien du tout, alors que la plage "couple" est celle-ci :



Merci par avance à ceux qui auront une idée.