Ajouter "Non" avec la couleur 38 par exemple

Bonjour le forum,

Quelles modifs apporter dans les macros suivantes pour ajouter "Non" de couleur 38 par exemple

Merci à vous

Cordialement

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim LastRow$, firstRow$
  Dim sh As Worksheet
  Application.ScreenUpdating = False
  For Each sh In ThisWorkbook.Worksheets
  If sh.Name <> "aaa" Then sh.Visible = xlSheetVeryHidden
    LastRow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1
   sh.Rows(LastRow & ":" & 200).EntireRow.Hidden = True
  Next sh
  Sheets(1).Select
  Application.ScreenUpdating = True
End Sub

Private Sub Workbook_Open()
Dim sh As Worksheet
  Application.ScreenUpdating = False
  For Each sh In ThisWorkbook.Worksheets
  sh.Visible = xlSheetVisible
    sh.Unprotect
    sh.Protect UserInterfaceOnly:=True
    sh.Rows("1:200").Hidden = False
  Next sh
  Sheets(1).Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)

  If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then
    Application.EnableEvents = False
    If Not IsDate(Target) Then
      Target.Resize(, 4).ClearContents
    Else
      Range("B" & Target.Row) = sh.Name
      Range("C" & Target.Row) = "Oui"
    End If
    Range("D" & Target.Row) = IIf(Target = "", "", CDate(Cells(Target.Row, 1)))
    Target = IIf(Target = "", "", Application.Proper(Format(CDate(Cells(Target.Row, 4)), "dddd dd mmmm yyyy")))
  End If
Range("A1").Select
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Indice As Integer, NbColonne As Integer
Dim Tb, TbCoul, X, TbFont, Label As String
Dim Ligne As Integer

    If Target.Address = "$A$2" Then Application.Run ("AfficherMasquerLignesVides")
  Cancel = True
    If Target.Address = "$A$2" Then Application.Run ("DeprotegerFeuilles")
  Cancel = True

Select Case UCase(sh.Name)

    Case "aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", _
         "hhh", "iii", "jjj", "kkk", "lll", "mmm", "nnn"

      NbColonne = 2
  End Select

 Ligne = Range("A" & Rows.Count).End(xlUp).Row
  If (Target.Row = Ligne And Range("A" & Ligne) <> "") Or (Target.Row = Ligne + 1 And Range("A" & Ligne + 1) = "") Then
    If Target.Column = NbColonne + 1 And Target.Row >= 3 Then
      Application.EnableEvents = False
      TbFont = Array(5, 1)
      TbCoul = Array(35, 40)
      Tb = Array("", "Oui")
      Cancel = True

      X = UCase(Trim(Target))
      If UBound(Filter(Tb, X, compare:=vbTextCompare)) >= 0 Then
        Indice = Application.Match(X, Tb, 0) Mod (1 + UBound(Tb))
        Label = Tb(Indice)
        With Target
          .Value = Label
          .Interior.ColorIndex = TbCoul(Indice)
          .Font.ColorIndex = TbFont(Indice)
        End With
        With ActiveCell.Offset(0, -NbColonne).Resize(1, NbColonne)
          If Label = "Oui" Then
            .Font.Strikethrough = True
            Target.Offset(, 1).Value = Date
            Target.Offset(, -2) = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))
            Target.Offset(, -1).Value = sh.Name

          Else
            .Font.Strikethrough = False
            Target.Offset(, 1).ClearContents
            Target.Offset(, -2).ClearContents
            Target.Offset(, -1).ClearContents
          End If
        End With
      End If

      Application.EnableEvents = True
    End If
  End If
Range("A1").Select
End Sub

Bonjour le forum

J'ai réussi à faire quelque chose qui fonctionne

Macro ci-dessous

Mais je voudrais faire mettre en interior color 7 lorsque je met Non toute la ligne colonne A à E

Merci à vous

Cordialement

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Indice As Integer, NbColonne As Integer
Dim Tb, TbCoul, X, TbFont, Label As String
Dim Ligne As Integer

    If Target.Address = "$A$2" Then
      Application.Run ("AfficherMasquerLignesVides")
      Application.Run ("DeprotegerFeuilles")
      Cancel = True
    End If

Select Case UCase(sh.Name)  ' Cette ligne permet de modifier l'onglet. Exemple "Couette Hiver" à la place de "COUETTE HIVER" sans modifier la macro "COUETTE HIVER"

Case "aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", _
         "hhh", "iii", "jjj", "kkk", "lll", "mmm", "nnn"

      NbColonne = 2
  End Select

 Ligne = Range("A" & Rows.Count).End(xlUp).Row
  If (Target.Row = Ligne And Range("A" & Ligne) <> "") Or (Target.Row = Ligne + 1 And Range("A" & Ligne + 1) = "") Then
    If Target.Column = NbColonne + 1 And Target.Row >= 3 Then       ' And Range("A" & Target.Row) <> "" Then
      Application.EnableEvents = False
      TbFont = Array(5, 1, 1)
      TbCoul = Array(35, 40, 7)
      Tb = Array("", "Oui", "Non")
      Cancel = True

      X = UCase(Trim(Target))
      If UBound(Filter(Tb, X, compare:=vbTextCompare)) >= 0 Then
        Indice = Application.Match(X, Tb, 0) Mod (1 + UBound(Tb))
        Label = Tb(Indice)
        With Target
          .Value = Label
          .Interior.ColorIndex = TbCoul(Indice)
          .Font.ColorIndex = TbFont(Indice)
        End With
        With ActiveCell.Offset(0, -NbColonne).Resize(1, NbColonne)
          If Label = "Oui" Then
            .Font.Strikethrough = True
            Target.Offset(, 1).Value = Date
            Target.Offset(, -2) = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))
            Target.Offset(, -1).Value = sh.Name

          ElseIf Label = "Non" Then
            .Font.Strikethrough = False
          Else
            .Font.Strikethrough = False
            Target.Offset(, 1).ClearContents
            Target.Offset(, -2).ClearContents
            Target.Offset(, -1).ClearContents
          End If
        End With
      End If

      Application.EnableEvents = True
    End If
  End If
Range("A1").Select
End Sub

Bonjour

sans fichier.... c'est jamais facile de proposer une solution car on ne peut pas la tester..;

aller je me tente :

 ElseIf Label = "Non" Then
            .Font.Strikethrough = False
  Else

a remplacer par

 ElseIf Label = "Non" Then
            .Font.Strikethrough = False
range(cells(target.row,"a"),cells(target.row,"E")).Interior.ColorIndex = 7
  Else

Fred

Bonjour fred2406

Avec un peu de retard je te répond que ça fonctionne.

Sans fichier pas facile voir impossible très souvent.

Merci à toi et bonne journée

Cordialement