Autres Modifier couleurs par double click

un internaute · 23 Septembre 2020

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 · 23 Septembre 2020

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

Autres Modifier couleurs par double click

un internaute

XLDnaute Impliqué

Dudu2

XLDnaute Barbatruc

Discussions similaires