Autres Modifier couleurs par double click

un internaute

XLDnaute Occasionnel
Bonjour le forum

Dans la macro ci-dessous je voudrais ajouter au 1er double click la couleur 15 aux cellules suivantes

Colonne E la couleur 15 (gris) dans les cellules suivantes E3, E5, E6, E7,E8
Puis au 2ème double click revenir aux couleurs originales ci-dessous

E3 = 34 (turquoise clair)

E5, E6 = 40 (brun)

E7 = 35 (vert clair)

E8 = 36 (jaune clair)

VB:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Cell As Range
    If Not Intersect(Target, Range("A2,I2")) Is Nothing Then
        Cancel = True
        Select Case Target.Column
            Case 1:
                For Each Cell In Sh.Range("E18:I24")
                    If Cell.Locked = False Then
                      If Cell.Interior.ColorIndex = 15 Then               'Couleur au Double Click cellule A2
                        If Cell.Column = 5 Or Cell.Column = 6 Then
                          Cell.Interior.ColorIndex = 2                    'Couleur blanc avant Double Click (colonnes E & F)
                        Else
                          Cell.Interior.ColorIndex = 36                   'Couleur jaune au Double Click (colonnes G à I)
                        End If
                      Else
                        Cell.Interior.ColorIndex = 15                     'Couleur au Double Click cellule A2
                      End If
                    End If
                Next Cell
            Case 9:
                Sh.Columns(10).Hidden = Not Sh.Columns(10).Hidden
        End Select
        Cells(1).Select
    End If
End Sub
Puis si j'oublie de faire le 2ème double pour effacer la couleur 15 dans les nouvelles cellules ci-dessous à l 'enregistrement
E3
E5, E6
E7
E8
Macro ci-dessous enregistrement


Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim J As Long, Feuille As Worksheet, Cell As Range   ' Ajouter Cell As Range pour modif du 05/09/2020
    Application.ScreenUpdating = False
    If ActiveSheet.Name = "MENU" Then                     'Ces 6 lignes pour Enregistrement par Feuille MENU ou Année en cours
      Set Feuille = Sheets("Charges " & Year(Date))       '********************************
    Else                                                  '********************************
      Set Feuille = ActiveSheet                           '********************************
    End If                                                '********************************
    With Feuille                                          '********************************
'      .Columns("G:I").Hidden = True                      'Mettre cette ligne en commentaires pour afficher colonnes G à I à l'ouverture et à l'Enregistrement
        For J = 12 To 112
          Select Case J
            Case 17, 32 To 38, 44, 59 To 65, 71, 86 To 92, 98
            Case Else
            If .Range("E" & J) = "" Then .Rows(J).Hidden = True
          End Select
        Next J
        
        ' Début modif pour remettre les couleurs à l'état initial lors de l'enregistrement le 05/09/2020
        '
        For Each Cell In .Range("E18:I24")
            If Cell.Locked = False Then
              If Cell.Interior.ColorIndex = 15 Then               'Couleur au Double Click cellule A2
                If Cell.Column = 5 Or Cell.Column = 6 Then
                  Cell.Interior.ColorIndex = 2                    'Couleur blanc avant Double Click (colonnes E & F)
                Else
                  Cell.Interior.ColorIndex = 36                   'Couleur jaune au Double Click (colonnes G à I)
                End If
              End If
            End If
        Next Cell
        '
        ' Fin modif pour remettre les couleurs à l'état initial lors de l'enregistrement le 05/09/2020
        
      Application.GoTo .Range("A12"), True
      ActiveSheet.Range("A1").Select
  End With

Application.ScreenUpdating = True
End Sub
Merci à vous pour vos éventuels retours
Cordialement

PS: j'ai posté sur un autre forum et j'ai reçu 2 réponses du même internaute
 

Dudu2

XLDnaute Accro
Bonjour,
Que veux-tu qu'on fasse avec le code de tes macros ?
Faut-il essayer de le comprendre ? Trop compliqué, pas de contexte. 30 minutes minimum de prise tête. Pas le temps. Je réponds à ta question, à toi de placer ce code dans ton environnement.

VB:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Me.Range("E3").Interior.ColorIndex <> 15 Then
        Me.Range("E3").Interior.ColorIndex = 15
        Me.Range("E5:E8").Interior.ColorIndex = 15
    Else
        Me.Range("E3").Interior.ColorIndex = 34
        Me.Range("E5:E6").Interior.ColorIndex = 40
        Me.Range("E7").Interior.ColorIndex = 35
        Me.Range("E8").Interior.ColorIndex = 36
    End If

    Cancel = True
End Sub
VB:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Const NomFeuille = "Feuil1" 'A adapter
   
    Me.Worksheets(NomFeuille).Range("E3").Interior.ColorIndex = 34
    Me.Worksheets(NomFeuille).Range("E5:E6").Interior.ColorIndex = 40
    Me.Worksheets(NomFeuille).Range("E7").Interior.ColorIndex = 35
    Me.Worksheets(NomFeuille).Range("E8").Interior.ColorIndex = 36
End Sub
 
Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas