Macro pour couleurs cellules au double click

Le 22/09/2020 à 07:00

Bonjour le forum

Dans la macro ci-dessous je voudrais ajouter au double click:

Colonne E la couleur 15 (gris) dans les cellules suivantes E3, E5, E6, E7,E8

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 = 34 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 = 34                     '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

Et ensuite dans la macro ci-dessous les faire revenir à leurs couleurs d'origine à l'enregistrement

E3 = 34 (turquoise clair)

E5, E6 = 40 (brun)

E7 = 35 (vert clair)

E8 = 36 (jaune clair)

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)    
Dim J As Long, Feuille As Worksheet, Cell As Range   
    Application.ScreenUpdating = False
    If ActiveSheet.Name = "MENU" Then                     
      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 = 34 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

Le 22/09/2020 à 09:56

Bonjour Al87,

A rajouter dans la 1ière macro juste avant For Each. Ne pas oublier de dimensionner Plage

Dim Plage as Range
.......
Case 1:
Set Plage = Application.Union(Range("E3"), Range("E5:E8"))
Plage.Interior.Color = 15
For Each Cell in Sh.Range("E18:I24")
.......

Puis à ajouter dans la 2ième macro pour revenir au colori de départ

Dim Plage as Range
....... 
Set Plage = Application.Union(Range("E3"), Range("E5:E8"))
Plage.Interior.Color = 2
For Each Cell In .Range("E18:I24")
......

Bons tests, bonne continuation.

Le 22/09/2020 à 16:08

Bonjour X Cellus

Ça me colorie en noir les cellules E3, E5:E8

Mais je pense que je n'ai pas compris où mettre tes modifs

Merci à toi

cordialement

Le 22/09/2020 à 20:06

A nouveau,

En fait en vérifiant en haut de ton message quelle couleur tu souhaitais. Donc la couleur grise.

J'ai tapé Interior.Color = 15 dans mon code au lieu de Interior.ColorIndex = 15. Et c'est bien ce dernier qui ressort la bonne couleur.

Désolé pour ce contre-temps.

Le 22/09/2020 à 21:02

Bonsoir X Cellus

C'est déjà mieux mais le double clic n'efface pas la couleur 15 dans les cellules E3, E5:E8 ni à l'enregistrement

Je pense que je le place mal ou alors il y a autre chose?

En tout cas un grand merci

Bonne fin de soirée

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
            Dim Plage As Range
            Case 1:
            Set Plage = Application.Union(Range("E3"), Range("E5:E8"))
            Plage.Interior.ColorIndex = 15
                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
Le 23/09/2020 à 13:52

Bonjour Al87,

Si tu souhaites un système à bascule modifie le code comme ci-dessous dans la 1ière macro.

If Plage.Interior.ColorIndex = 15 Then Plage.Interior.ColorIndex = xlNone Else Plage.Interior.ColorIndex = 15

Ainsi un 1ier double clic sur A2 ou I2 mettra la plage de cellules sous fond gris. Puis un second double clic l'annulera pour remettre la cellule sans couleur.

Pour la deuxième macro faire seulement Plage.Interior.ColorIndex = xlNone

Bonne continuation.

Le 23/09/2020 à 14:11

Bonjour X Cellus

On progresse on progresse

Effectivement au 2èe click ça remet bien couleur 2 (blanc) alors qu'il faut que ça soit les couleurs d'origne.

E3 = 34 (turquoise clair)

E5, E6 = 40 (brun)

E7 = 35 (vert clair)

E8 = 36 (jaune clair)

Voici la macro 2

Je met où STP

On va bien finir par y arriver?

Merci beaucoup à toi

A+

Plage.Interior.ColorIndex = xlNone
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 = 34 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
Le 23/09/2020 à 15:03

A nouveau,

Effectivement j'ai repris ton 1ier message. Il y a des couleurs d'origine pour ces cellules. Faut que je prenne RDV chez l'opticien/oculiste....

Bon, on modifie (une dernière fois) j'espère. Avec un code un peu plus long. En 1ière macro

Dim Plage As Range
Kolor = "3440403536": C = -1
Set Plage = Application.Union(Range("E3"), Range("E5:E8"))
If Plage.Interior.ColorIndex = 15 Then
For Each Cell In Plage
C = C + 2
Cell.Interior.ColorIndex = CInt(Mid(Kolor, C, 2))
Next
Else: Plage.Interior.ColorIndex = 15
End If

Toujours à placer comme dans les précédents messages.

En 2ième macro ne pas reprendre le Else: Plage.interior.ColorIndex=15. Ce qui remettrait en fonds gris.

Bons tests, bonne continuation.

Le 24/09/2020 à 06:40

Bonjour X Cellus

Merci pour ton calme et ton abnégation.

Il faut reconnaitre que sans fichier ça n'aide pas.

On y est presque je vais finaliser quelques bricoles.

Un grand merci à toi

Je te souhaite une bonne journée

Très cordialement

Rechercher des sujets similaires à "macro couleurs double click"