Remplacer MFC mise en forme date par cde VBA

Version imprimable

27/05/2019, 12h22
Leelya

Remplacer MFC mise en forme date par cde VBA

Bonjour à tous,

Désolée si la question a déjà été posée, mais je n'ai pas trouvé ma réponse...

j'ai un tableau qui se présente sous la forme suivante :
Colonne A = réunion groupe A
Colonne B = date de réalisation
Colonne C = à faire tous les 365 jours
Colonne D = date de la prochaine réunion = colonne B + colonne C

Actuellement, j'ai une mise en forme conditionnelle pour colorer la colonne D. En rouge si la date est dépassée, en orange, si elle est dans le mois à venir, en vert pour le reste.

Je voudrais remplacer ma MFC par une cde VBA pour calculer le nombre de cellules rouges, oranges et vertes.

Je ne veux pas utiliser une formule sur la date, j'ai un autre tableau pour lequel j'ai une formule en plus pour le calcul de la date, et si j'ai ma cde VBA pour remplacer la MFC sur ce tableau, je l'ai pour les autres...

Merci pour votre aide.

Bonjour
La demande n'est pas tout à fait claire au moins pour moi
mais si tu cherches à contrôler une date qui se trouve dans la colonne D et tu aura un message d'alerte si la date est expirée
et un autre message si la date arrive à échéance à moins de 7 jours
et aucun message si l'échéance est de plus de 7 jours tu peux tester ce code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Sub alerte() Dim w1 As Worksheet Dim i As Long Dim D As Date Dim j As Integer Set w1 = Worksheets("feuil1") 'Feuille qui contient les alertes D = Date For i = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row If (w1.Range("D" & i) - Date) < 0 Then MsgBox ("ATTENTION !!!! La date d'échéance pour " & Cells(i, "A").Value & " " & " à déja expirée depuis le : " & Cells(i, "D").Value) If (w1.Range("D" & i) - Date) <= 7 And (w1.Range("D" & i) - Date) >= 0 Then MsgBox ("ATTENTION !!!! La date d'échéance pour " & Cells(i, "A").Value & " " & " arrive à échéance le : " & Cells(i, "D").Value) Next i End Sub

27/05/2019, 13h47
Leelya

1 pièce(s) jointe(s)

Bonjour, BENNASR,

Effectivement, en me relisant, je vois bien que je n'ai pas été claire du tout...
Je vais mettre une PJ pour que ça soit plus simple...
Pièce jointe 478384

Je souhaiterais remplacer l'actuelle mise en forme conditionnelle de ma colonne D par une cde VBA. L'objectif final étant, grâce à une cde VBA aussi, de déterminer le nombre de cellules rouges, orange et vertes.

1 pièce(s) jointe(s)

re
bonjour
un petit exemple puisqu'en ce moment je vais joujou avec les formule converti en vba ;)
et de récupérer le résultat avec evaluate

en colonne A et B j'ai des dates
je compare B à A

si B plus grand(+365 jour) rouge sinon vert

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Function quelle_couleur(add1 As Range, add2 As Range, coulplus As Long, coulmoins As Long, différence As Long)
Dim formula As String
formula = "IF(add1-add2>" & différence & ",""coulplus"",""coulmoins"")"
formula = Replace(Replace(formula, "add1", add1.Address(0, 0)), "add2", add2.Address(0, 0))
formula = Replace(Replace(formula, "coulplus", coulplus), "coulmoins", coulmoins)
c = Val(Evaluate(formula))
Debug.Print formula & "couleur resultante = " & c
quelle_couleur = c
End Function
'
Sub MFCVBA()
For i = 1 To 100
Cells(i, 2).Interior.Color = quelle_couleur(Cells(i, 2), Cells(i, 1), vbRed, vbGreen, 365)
Next
End Sub

Pièce jointe 478388
a noter que j'aurais pu faire directement sans replace

Code:

1
2
3
4
5
6
7
8
9
10
Function quelle_couleur(add1 As Range, add2 As Range, coulplus As Long, coulmoins As Long, différence As Long)
Dim formula As String
formula = "IF(" & add1.Address(0, 0) & "-" & add2.Address(0, 0) & ">" & différence & "," & Chr(34) & coulplus & Chr(34) & "," & Chr(34) & coulmoins & """)"
'formula = "IF(add1-add2>" & différence & ",""coulplus"",""coulmoins"")"
'formula = Replace(Replace(formula, "add1", add1.Address(0, 0)), "add2", add2.Address(0, 0))
'formula = Replace(Replace(formula, "coulplus", coulplus), "coulmoins", coulmoins)
c = Val(Evaluate(formula))
Debug.Print formula & "couleur resultante = " & c
quelle_couleur = c
End Function

1 pièce(s) jointe(s)

re
demo d'utilisation avec plusieur conditions différentes

+ d'un mois
+ de 3 mois
+ d'un an
+ de 500 jours
etc...etc...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Function quelle_couleur(R1 As Range, R2 As Range, C1 As Long, C0 As Long, d As Long)
Dim formula As String
formula = "IF(" & R1.Address(0, 0) & "-" & R2.Address(0, 0) & ">" & d & "," & Chr(34) & C1 & Chr(34) & "," & Chr(34) & C0 & """)"
c = Val(Evaluate(formula))
'Debug.Print formula & "couleur resultante = " & c
quelle_couleur = c
End Function
'
'
Sub MFCVBA()
For i = 1 To 100
Cells(i, 2).Interior.Color = quelle_couleur(Cells(i, 2), Cells(i, 1), RGB(255, 150, 255), vbGreen, 31) '+ d'un  mois'rose claire
Cells(i, 2).Interior.Color = quelle_couleur(Cells(i, 2), Cells(i, 1), RGB(255, 0, 255), Cells(i, 2).Interior.Color, 92) '+ de 3  mois'magenta
Cells(i, 2).Interior.Color = quelle_couleur(Cells(i, 2), Cells(i, 1), vbRed, Cells(i, 2).Interior.Color, 365) '+d'un an' rouge 
Cells(i, 2).Interior.Color = quelle_couleur(Cells(i, 2), Cells(i, 1), RGB(255, 255, 100), Cells(i, 2).Interior.Color, 500) '+ de 500 jours jaune paille
Next
End Sub

il ne te reste plus qu'a adapter tes cellules1 et 2 et tes couleur souhaitées et la différence dans la sub MFCVBA
Pièce jointe 478404
les verts qui restent sont celles qui ont moins d'un moi de différence

1 pièce(s) jointe(s)

RE
pose ta question dans ton post plutôt qu'en MP
donc en réponse a ton mp
a savoir comparer la date d'aujourd'hui a celle d'une date de réunion prévue
on prends les meme on ajoute un peu de sel poivre et romarin change le safran pour le curry et on continue

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Function quelle_couleur2(R1 As Range, dat As Date, C1 As Long, C0 As Long, d As Long)
Dim formula As String,c as long
formula = "IF(" & CLng(CDate(R1.Value)) & "-" & CLng(dat) & ">" & Val(d) & "," & Chr(34) & C1 & Chr(34) & "," & Chr(34) & C0 & """)"
c = Val(Evaluate(formula))
Debug.Print formula & "couleur résultante = " & c
quelle_couleur2 = c
End Function
'
'
Sub MFCVBA2()
'a combien d'aujourd'hui la date de réunion et elle prévues  en couleur SVP!!!
For i = 1 To 100
Cells(i, 2).Interior.Color = quelle_couleur2(Cells(i, 2), Date, RGB(100, 150, 255), vbGreen, 30) '+ d'un  mois MAIS !! moins de 3
Cells(i, 2).Interior.Color = quelle_couleur2(Cells(i, 2), Date, RGB(255, 0, 255), Cells(i, 2).Interior.Color, 92) '+ de 3  mois
Cells(i, 2).Interior.Color = quelle_couleur2(Cells(i, 2), Date, vbRed, Cells(i, 2).Interior.Color, 365) '+d'un an
Cells(i, 2).Interior.Color = quelle_couleur2(Cells(i, 2), Date, RGB(255, 255, 100), Cells(i, 2).Interior.Color, 500) '+ de 500 jours
Next

Pièce jointe 478440

27/05/2019, 16h07
Leelya

Merci, Patrick.

Pour la ligne 13, est-il possible de demander les valeurs d'une colonne, sans forcément préciser le nombre de lignes ?
Si je veux basculer les formules sur une autre colonne, je dois changer le 2 de Cells(i,2) ?

Je suis désolée, je suis novice dans les VBA...
27/05/2019, 16h49
patricktoulon

re

re
oui
dans mon exemple je compare B a date a la place de 2 tu met le numéro de colonne que tu veux ou la lettre entre guillemet, si c'est plus explicite pour toi
exemple
cells(i,"G") c'est pareil que cells(i,7)

1 pièce(s) jointe(s)

Bonsoir

Autre proposition avec une évènementielle qui agit à chaque changement d’une cellule du Tableau nommé Bd (présent dans l’exemple joint) provoquant la formule.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [Bd[[Réalisée le]:[périodicité]]]) Is Nothing And Target.Count = 1 Then 
         Dim R As Range, nv As Integer, nr As Integer
        For Each R In [Bd[Échéance]]
             R.Interior.ColorIndex = 44
            Select Case R.Value
                Case Is < Now: R.Interior.ColorIndex = 3: nr = nr + 1:
                Case Is > Now + 30: R.Interior.ColorIndex = 4: nv = nv + 1
            End Select
        Next
        Cells(3, 6) = nr: Cells(3, 8) = nv: Cells(3, 7) = [Bd].Rows.Count - nr - nv
    End If
End Sub

On peut ajouter des cas sans problème.

28/05/2019, 09h34
Leelya

Citation:

Envoyé par patricktoulon

re
oui
dans mon exemple je compare B a date a la place de 2 tu met le numéro de colonne que tu veux ou la lettre entre guillemet, si c'est plus explicite pour toi
exemple
cells(i,"G") c'est pareil que cells(i,7)

Merci Patrick !

Citation:

Envoyé par OrDonc

Bonsoir

Autre proposition avec une évènementielle qui agit à chaque changement d’une cellule du Tableau nommé Bd (présent dans l’exemple joint) provoquant la formule.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [Bd[[Réalisée le]:[périodicité]]]) Is Nothing And Target.Count = 1 Then 
         Dim R As Range, nv As Integer, nr As Integer
        For Each R In [Bd[Échéance]]
             R.Interior.ColorIndex = 44
            Select Case R.Value
                Case Is < Now: R.Interior.ColorIndex = 3: nr = nr + 1:
                Case Is > Now + 30: R.Interior.ColorIndex = 4: nv = nv + 1
            End Select
        Next
        Cells(3, 6) = nr: Cells(3, 8) = nv: Cells(3, 7) = [Bd].Rows.Count - nr - nv
    End If
End Sub

On peut ajouter des cas sans problème.

Bonjour, OrDonc,

Effectivement, tu réponds du coup à la suite de mon projet. ce qui me convient très bien ! :D Cependant, lorsque j'intègre le code dans mon module (ou ma feuille, j'ai le même résultat...), il ne trouve pas le "nom" de la cde à exécuter... J'ai essayé de l'intégrer comme ça :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub nom cde()
Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [Bd[[Réalisée le]:[périodicité]]]) Is Nothing And Target.Count = 1 Then 
         Dim R As Range, nv As Integer, nr As Integer
        For Each R In [Bd[Échéance]]
             R.Interior.ColorIndex = 44
            Select Case R.Value
                Case Is < Now: R.Interior.ColorIndex = 3: nr = nr + 1:
                Case Is > Now + 30: R.Interior.ColorIndex = 4: nv = nv + 1
            End Select
        Next
        Cells(3, 6) = nr: Cells(3, 8) = nv: Cells(3, 7) = [Bd].Rows.Count - nr - nv
    End If
End Sub

Mais ça veut pas... :calim2:

2 pièce(s) jointe(s)

Code:

1
2
Private Sub nom cde()
Worksheet_Change(ByVal Target As Range)

Pose problème car la seconde ligne n’est pas reconnue par le VBA. Garde bien cette ligne

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Tu pourrais avoir un autre problème avec le nom du tableau
J’ai remplacé le tien par Bd.
Si tu ne l’as pas fait, avec le nom d’origine Tableau1, copie sans ne rien changer :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [Tableau1[[Réalisée le]:[périodicité]]]) Is Nothing And Target.Count = 1 Then
        Dim R As Range, nv As Integer, nr As Integer
        For Each R In [Tableau1[Échéance]]
            R.Interior.ColorIndex = 44
            Select Case R.Value
                Case Is < Now: R.Interior.ColorIndex = 3: nr = nr + 1:
                Case Is > Now + 30: R.Interior.ColorIndex = 4: nv = nv + 1
            End Select
        Next
        Cells(3, 6) = nr: Cells(3, 8) = nv: Cells(3, 7) = [Tableau1].Rows.Count - nr - nv
    End If
End Sub

Tu retrouveras cela dans l’adaptation faite.
Pour le nom du tableau

28/05/2019, 11h32
Leelya

Génial !

Merci à tous et pour tout !