Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)

un internaute · 17 Février 2023

Bonjour le forum
Je voudrais mettre en couleur la ligne contenant "Repos "Congés" par VBA car les 3 MFC occupées
Colonnes B à E

La colonne A est bonne

Macro ci-dessous

VB:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour As Integer
Dim Ladate As Date
Dim MoisSuivant As String
Dim sDate As String, ValDate As Variant
Dim MoisPrec As String

    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Sh.Range("B6:B36")) Is Nothing Then
        If Target.Value = "" Then
            Cells(Target.Row, "A").Resize(, 3) = ""
            Cells(Target.Row, "I") = ""
        ElseIf IsNumeric(Target) Then       ' Ajout ligne Modifs le 09/02/2023 pour pouvoir taper un nombre même s'il y a Repos ou Congés dans la cellule colonne B
            Cells(Target.Row, "C") = ""     ' Ajout ligne Modifs le 09/02/2023 pour pouvoir taper un nombre même s'il y a Repos ou Congés dans la cellule colonne B
        End If
    End If
 
  If Not Intersect(Target, Sh.Range("F2:F3")) Is Nothing Then          '1ère ligne en commentaires pour employer le /
    ValDate = Target.Value2
    If IsNumeric(ValDate) Then
      ' Selon la saisie effectuée
      Select Case Len(ValDate)
      Case 4  ' format jmaa
        sDate = "0" & Left(ValDate, 1) & "/0" & Mid(ValDate, 2, 1) & "/" & Right(ValDate, 2)
      Case 5  ' format jmmaa
        sDate = "0" & Left(ValDate, 1) & "/" & Mid(ValDate, 2, 2) & "/" & Right(ValDate, 2)
      Case 6  ' format jjmmaa
        sDate = Left(ValDate, 2) & "/" & Mid(ValDate, 3, 2) & "/" & Right(ValDate, 2)
      Case 7  ' format jmmaaaa
        sDate = Left(ValDate, 1) & "/" & Mid(ValDate, 2, 2) & "/" & Right(ValDate, 4)
      Case 8  ' format jjmmaaa
        sDate = Left(ValDate, 2) & "/" & Mid(ValDate, 3, 2) & "/" & Right(ValDate, 4)
      End Select
      End If
      
      Dim J As Integer
      Dim Total As Double
      
      Application.EnableEvents = False
      On Error Resume Next
      Target.Value = CDate(sDate)
      On Error GoTo 0
      Target.NumberFormat = "dd mmm yyyy"
      Application.EnableEvents = True
      
      If Month(DateValue(Sh.Name)) > 1 Then
        MoisPrec = Application.Proper(Format(DateAdd("m", -1, DateValue(Sh.Name)), "Mmmm yyyy"))
        If Target <= CDate(Range("'" & MoisPrec & "'!F3")) Then
          MsgBox "Attention " & vbCr & vbCr & "La date inscrite est plus petite que la dernière date de la feuille " & MoisPrec
          Application.EnableEvents = False
          Target = ""
          Application.EnableEvents = True
          Exit Sub
        Else
          For J = 36 To 6 Step -1          '******* Nouvelle partie de macro Début
          If Range("'" & MoisPrec & "'!I" & J) <> "" Then
          If CDate(Range("F2")) <= CDate(Range("'" & MoisPrec & "'!I" & J)) Then Total = Total + _
            Val(Range("'" & MoisPrec & "'!D" & J)) + _
            Val(Range("'" & MoisPrec & "'!E" & J))

          End If
          Next J
           Range("F6") = TotalFrais([F2], [F3])
          End If
          End If                           '******* Nouvelle partie de macro Fin
  Else                                     '1ère ligne en commentaires pour employer le /
    Application.EnableEvents = False
    ' On recherche si la page est surveillée
    If InStr(1, "JanvierFévrierMarsAvrilMaiJuinJuilletAoûtSeptembreOctobreNovembreDécembre", _
                Split(Sh.Name, " ")(0), vbTextCompare) Then
      ' Calcul du nombre de jour dans le mois indiqué par le nom de la feuille
      NombreJour = Day(DateAdd("m", 1, DateValue(Sh.Name)) - 1)
      
      If Target.Row - 5 > Day(Date) Then
        Beep
        MsgBox "PAS LE BON JOUR"
        Target = ""
      Else
 
        ' Surveille la plage du 1er au dernier jours du mois
        'If Not Intersect(Range("B6:C" & 5 + NombreJour, "F6:F" & 5 + NombreJour), Target) Is Nothing Then
        If Not Intersect(Range("B6:C" & 5 + NombreJour), Target) Is Nothing Then
          ' Reconstruit la date de fonction du nom de la feuille et du numéro de ligne sélectionnée
          Ladate = DateSerial(Split(Sh.Name, " ")(1), Month(DateValue(Sh.Name)), Target.Row - 5)
          ' Si la colonne B et la colonne C est vide on efface la date
          Select Case Range("B" & Target.Row)
            Case "Repos", "Congés"
              Range("C" & Target.Row) = Range("B" & Target.Row)
          End Select
          If Range("B" & Target.Row) = "Congés" Or Range("B" & Target.Row) = "Repos" Then Range("C" & Target.Row) = Range("B" & Target.Row)
          Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Application.Proper(Format(Ladate, "dddd dd mmmm yyyy")))
          Range("I" & Target.Row) = IIf(Range("A" & Target.Row) & Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Ladate)
          Range("H" & Target.Row) = IIf(Not (IsNumeric(Range("B" & Target.Row))), 0, 1)
          If Range("B" & Target.Row) = "" Then
            Range("H" & Target.Row) = ""
          ElseIf Weekday(CDate(Range("I" & Target.Row)), 2) >= 6 Then   'Modifs le 12/02//2023 pour ne pas afficher 1 dans colonne H. Avant modifs = 6 Then
            Range("H" & Target.Row) = 0
          End If
          ' si la ligne modifiée est la dernière du mois et que la colonne est la C
          If Target.Row = NombreJour + 5 And Target.Column = 3 Then       ' Colonne C
            ' On construit le nom de la feuille du mois suivant
            MoisSuivant = MonthName(Month(DateAdd("m", 1, DateValue(Sh.Name)))) & " " & Year(DateAdd("m", 1, DateValue(Sh.Name)))
            ' On va vérifier si la feuille existe
            If FeuilleExiste(MoisSuivant) = False Then   'Exit Function
            ' La feuille existe
            With Sheets(MoisSuivant)
              'On la rend visible
              .Visible = xlSheetVisible
              ' On masque celle que l'on vient de finir
              ActiveSheet.Visible = xlSheetHidden
              ' et on la sélectionne
              .Select
            End With
          End If
        End If
      End If
    End If
  End If                                           'Mettre en commentaires pour employer le /
  End If
 
  Application.EnableEvents = True
'End Function
End Sub

Merci à vous pour vos éventuels retours

un internaute · 17 Février 2023

Re bonjour le forum
J'ai une idée qui peut fonctionner
Je met résolu pour évier que vous cherchiez
Je reviendrais vers vous si ça ne fonctionne pas ou pour mettre la solution
Bien cordialement

un internaute · 18 Février 2023

Bonjour le forum
Non pas pu y arriver
Alors je m'en remet à votre compétence
Donc pour résumer mettre en interior.color =3 ligne de B à E lorsqu'il y a "Repos" ou "Congés"
Cordialement

un internaute · 20 Février 2023

Bonjour le forum
Pas résolu mais je clôture
Bonne semaine à tous

TooFatBoy · 20 Février 2023

Bonjour,

un internaute à dit:
Pas résolu mais je clôture

Moi aussi je bricole en ce moment : j'essaye de poser une armoire de toilette dans la salle de bain, mais c'est la galère...
Bon courage à toi pour ta clôture.

TooFatBoy · 20 Février 2023

Plus sérieusement, si tu n'as pas eu de réponse, je crois que c'est parce que tu n'as pas fourni un petit fichier anonymisé représentatif de ton vrai fichier et de ton problème. 😉

un internaute · 20 Février 2023

Bonjour TooFatBoy
Oui moi aussi poteaux ciment c'est pour ça que je clôture
Tu ne galère pas puisque tu es sur le forum!!!
Courage à toi

TooFatBoy · 20 Février 2023

un internaute à dit:
Tu ne galère pas puisque tu es sur le forum!!!

J'étais en cours de recherche d'une solution sur internet quand j'ai eu une notification. Donc j'ai accouru.

un internaute · 20 Février 2023

Non ne plus rechercher. Dans la semaine je donne la solution quand j'ai terminé la clôture
Même anonymisé pas possible

TooFatBoy · 20 Février 2023

un internaute à dit:
Non ne plus rechercher.

OK. Comme tu veux. 😉

un internaute · 20 Février 2023

Non merci
Bonne semaine

un internaute · 21 Février 2023

Bonsoir le forum
Comme convenu avec TooFatBoy!!!
Qui lui a certainement terminé de monter son armoire de toilette dans la salle de bain!!!
Et moi je"rame"!!!
Bonne fin de soirée
Cordialement

VB:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour As Integer
Dim Ladate As Date
Dim MoisSuivant As String
Dim sDate As String, ValDate As Variant
Dim MoisPrec As String

    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Sh.Range("B6:B36")) Is Nothing Then
      Application.EnableEvents = False
        If Target.Value = "" Then
            Cells(Target.Row, "A").Resize(, 3) = ""
            Cells(Target.Row, "I") = ""
        ElseIf IsNumeric(Target) Then
            Cells(Target.Row, "C") = ""
        End If
    End If
 
  If Not Intersect(Target, Sh.Range("F2:F3")) Is Nothing Then
    ValDate = Target.Value2
    If IsNumeric(ValDate) Then
      ' Selon la saisie effectuée
      Select Case Len(ValDate)
      Case 4  ' format jmaa
        sDate = "0" & Left(ValDate, 1) & "/0" & Mid(ValDate, 2, 1) & "/" & Right(ValDate, 2)
      Case 5  ' format jmmaa
        sDate = "0" & Left(ValDate, 1) & "/" & Mid(ValDate, 2, 2) & "/" & Right(ValDate, 2)
      Case 6  ' format jjmmaa
        sDate = Left(ValDate, 2) & "/" & Mid(ValDate, 3, 2) & "/" & Right(ValDate, 2)
      Case 7  ' format jmmaaaa
        sDate = Left(ValDate, 1) & "/" & Mid(ValDate, 2, 2) & "/" & Right(ValDate, 4)
      Case 8  ' format jjmmaaa
        sDate = Left(ValDate, 2) & "/" & Mid(ValDate, 3, 2) & "/" & Right(ValDate, 4)
      End Select
      End If
      
      Dim J As Integer
      Dim Total As Double
      
      Application.EnableEvents = False
      On Error Resume Next
      Target.Value = CDate(sDate)
      On Error GoTo 0
      Target.NumberFormat = "dd mmm yyyy"
      Application.EnableEvents = True
      
      If Month(DateValue(Sh.Name)) > 1 Then
        MoisPrec = Application.Proper(Format(DateAdd("m", -1, DateValue(Sh.Name)), "Mmmm yyyy"))
        If Target <= CDate(Range("'" & MoisPrec & "'!F3")) Then
          MsgBox "Attention " & vbCr & vbCr & "La date inscrite est plus petite que la dernière date de la feuille " & MoisPrec
          Application.EnableEvents = False
          Target = ""
          Application.EnableEvents = True
          Exit Sub
        Else
          For J = 36 To 6 Step -1          '******* Nouvelle partie de macro Début
          If Range("'" & MoisPrec & "'!I" & J) <> "" Then
          If CDate(Range("F2")) <= CDate(Range("'" & MoisPrec & "'!I" & J)) Then Total = Total + _
            Val(Range("'" & MoisPrec & "'!D" & J)) + _
            Val(Range("'" & MoisPrec & "'!E" & J))

          End If
          Next J
           Range("F6") = TotalFrais([F2], [F3])
          End If
          End If                           '******* Nouvelle partie de macro Fin
  Else                                     '1ère ligne en commentaires pour employer le /
    Application.EnableEvents = False
    ' On recherche si la page est surveillée
    If InStr(1, "JanvierFévrierMarsAvrilMaiJuinJuilletAoûtSeptembreOctobreNovembreDécembre", _
                Split(Sh.Name, " ")(0), vbTextCompare) Then
      ' Calcul du nombre de jour dans le mois indiqué par le nom de la feuille
      NombreJour = Day(DateAdd("m", 1, DateValue(Sh.Name)) - 1)
      
      If Target.Row - 5 > Day(Date) Then
        Beep
        MsgBox "PAS LE BON JOUR"
            Target = ""
            Range(Cells(Target.Row, 1), Cells(Target.Row, 7)).Interior.ColorIndex = 8
      Else
        ' Surveille la plage du 1er au dernier jours du mois
        If Not Intersect(Range("B6:C" & 5 + NombreJour), Target) Is Nothing Then
          ' Reconstruit la date de fonction du nom de la feuille et du numéro de ligne sélectionnée
          Ladate = DateSerial(Split(Sh.Name, " ")(1), Month(DateValue(Sh.Name)), Target.Row - 5)
          ' Si la colonne B et la colonne C est vide on efface la date
          Select Case Range("B" & Target.Row)
            Case "Repos", "Congés"
              Range("C" & Target.Row) = Range("B" & Target.Row)
          End Select
          If Range("B" & Target.Row) = "Congés" Or Range("B" & Target.Row) = "Repos" Then Range("C" & Target.Row) = Range("B" & Target.Row)
          Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Application.Proper(Format(Ladate, "dddd dd mmmm yyyy")))
          Range("I" & Target.Row) = IIf(Range("A" & Target.Row) & Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Ladate)
          Range("H" & Target.Row) = IIf(Not (IsNumeric(Range("B" & Target.Row))), 0, 1)
          If Range("B" & Target.Row) = "" Then
            Range("H" & Target.Row) = ""
          ElseIf Weekday(CDate(Range("I" & Target.Row)), 2) >= 6 Then   'Modifs le 12/02//2023 pour ne pas afficher 1 dans colonne H. Avant modifs = 6 Then
            Range("H" & Target.Row) = 0
          End If
          
            Dim Plage As Range, Cel As Range, I As Integer
          
            'If Range("A" & Target.Row) <> "" Then
                Application.ScreenUpdating = False   'NombreJour
                Set Plage = Range(Cells(6, 1), Cells(5 + NombreJour, 1)).Resize(, 5)
               'Mémorise le formatage de la colonne A puis passe la colonne A au format "Standard" pour avoir des valeurs de type Long
               'Effectue la recherche de la date en type Long sur la colonne A
               Plage.Columns(9).Hidden = False
                Set Cel = Plage.Columns(9).Find(Date, , xlValues, xlWhole)
               Plage.Columns(9).Hidden = True
                
                'Puis rétabli le format
                'Plage.Columns(1).NumberFormat = F
                Plage.Interior.ColorIndex = 8
                'Si trouvée, mets la plage au fond 8 puis colore la ligne du jour
                If Not Cel Is Nothing Then
                    Range(Cells(Cel.Row, 1), Cells(Cel.Row, Plage.Columns.Count)).Interior.ColorIndex = 3
                    J = Cel.Row - 1
                End If

                If J = 0 Then J = Plage.Rows.Count + 6
                'Colore ensuite les cellules en fonction du jour
                For I = 6 To J
                    If Cells(I, 1).Value <> "" Then
                        If Application.CountIf(Sheets("Menu").Range("JoursFériés"), Range("I" & I)) > 0 Or Weekday(Range("I" & I), vbMonday) > 5 Then
                            Range("A" & I & ":E" & I).Interior.ColorIndex = 38
                        Else
                            Range("A" & I).Interior.ColorIndex = 15
                            Range("B" & I).Interior.ColorIndex = 36
                            Range("C" & I).Interior.ColorIndex = 35
                            Range("D" & I).Interior.ColorIndex = 36
                            Range("E" & I).Interior.ColorIndex = 35
                            
                        End If
                    End If
                Next I
              Application.ScreenUpdating = True
          
            ' si la ligne modifiée est la dernière du mois et que la colonne est la C
          If Target.Row = NombreJour + 5 And Target.Column = 3 Then       ' Colonne C
            ' On construit le nom de la feuille du mois suivant
            MoisSuivant = MonthName(Month(DateAdd("m", 1, DateValue(Sh.Name)))) & " " & Year(DateAdd("m", 1, DateValue(Sh.Name)))
            ' On va vérifier si la feuille existe
            If FeuilleExiste(MoisSuivant) = False Then   'Exit Function
            ' La feuille existe
            With Sheets(MoisSuivant)
              'On la rend visible
              .Visible = xlSheetVisible
              ' On masque celle que l'on vient de finir
              ActiveSheet.Visible = xlSheetHidden
              ' et on la sélectionne
              .Select
            End With
          End If
          
        End If
      End If
    End If
  End If
  End If
  Application.EnableEvents = True
'End Function
End Sub

un internaute · 21 Février 2023

Je ne peux plus mettre [RÉSOLU]?

TooFatBoy · 21 Février 2023

Normalement tu peux toujours mettre [RÉSOLU], mais pour clore un fil de discussion il faut cocher la réponse la mieux adaptée.

un internaute · 21 Février 2023

Bonsoir TooFatoy
Tu as pensé à ma clôture?
Je regarderais demain matin
Bonne fin de soirée

Effectuez une recherche sur Excel Downloads...

Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)

un internaute

XLDnaute Impliqué

un internaute

un internaute

XLDnaute Impliqué

un internaute

XLDnaute Impliqué

un internaute

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

un internaute

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

un internaute

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

un internaute

XLDnaute Impliqué

un internaute

XLDnaute Impliqué

un internaute

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

un internaute

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée

Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

​

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée