Cellule Colorié en double clic

Bonjour,

Voici un fichier que j'ai fait pour des objectifs. J'ai déjà utilisé un formulaire semblable avec les même code VBA et cela fonctionnait à merveille. (Dès que je double clique sur une cellule, elle se colore, le texte devient gras et un chiffre va se mettre dans une autre cellule.

Dans ce fichier, dès que je double clique, l'opération s'effectue et s'efface aussi vite ?

Pourriez-vous m'aider à résoudre mon problème ?

Très bonne fin de journée

Fornstep

Je ne prendrai que la plage B15:F15. Il faut mettre un Exit Sub à la fin du bloc. A tester avec le reste.

 If Not Application.Intersect(Target, Range("B15:F15")) Is Nothing Then

    Cancel = True
    With Target
        For i = 2 To 6
            If i = .Column And Not (.Font.Bold And .Interior.ColorIndex = 37) Then PutColor = True Else PutColor = False
            MiseEnForme Cells(.Row, i), PutColor, 1
        Next i
    End With
    Exit Sub
End If

Merci mais malheureusement ça ne fonctionne toujours pas

Très belle soirée

Bonsoir,

Voir si la Pj ci-jointe fonctionne chez toi...... maintenant!!

Slts

Bonjour à tous,

Chez moi a marche. J'ai mis toutes les 1res cellules en bleu pour te le prouver. Au passage, tu as un bloc qui met le bouze : B12:F114 au lieu de B112:F114.

Juste une dernière remarque : ton code n'est pas optimisé. Il occupe 207 lignes parce qu'il est exhaustif. Or un algo est possible grâce aux colonnes constantes. On peut l'écrire en 25 lignes que je te propose.

Les datas correspondent aux n° de lignes cliquables et les chiffres marchent par deux (ex : 15,0 = 15:15 + 0 et 112,2 = 112:112+2).

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim PutColor As Boolean, i As Integer, j As Integer
    Dim datas As String, table() As String

    datas = "15,0,31,0,47,0,63,0,80,2,95,2,112,2,127,1,143,2,158,2,175,1,189,2,206,2,221,1"
    table = Split(datas, ",")

    For j = 0 To 27 Step 2 ' datas du tableau
        If Not Application.Intersect(Target, Range("B" & Val(table(j)) & ":F" & Val(table(j)) + Val(table(j + 1)))) Is Nothing Then
            Me.Unprotect ("Raiffeisen2021")
            Cancel = True
            With Target
                For i = 2 To 6
                    If i = .Column And Not (.Font.Bold And .Interior.ColorIndex = 37) Then PutColor = True Else PutColor = False
                    With Cells(.Row, i)
                        .Interior.ColorIndex = IIf(Surbrillance, 37, xlNone)
                        .Offset(0, 7).Value = IIf(Surbrillance, .Column - delta, "")
                        .Font.Bold = Surbrillance
                    End With
                Next i
            End With
            Me.Protect Password:="Raiffeisen2021", DrawingObjects:=True, Contents:=True, Scenarios:=True
        End If
    Next j
End Sub

Merci pour votre aide

Merci pour le nouveau code qui est effectivement bien plus court

Bonne journée