Discussion :

[Leelya]

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.

[BENNASR]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Leelya]

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...
Exemple.xlsm

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.

[patricktoulon]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

a noter que j'aurais pu faire directement sans replace

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[patricktoulon]

re
demo d'utilisation avec plusieur conditions différentes

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

les verts qui restent sont celles qui ont moins d'un moi de différence

[patricktoulon]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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...

[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)

[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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[Leelya]

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 !

[Leelya]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 ! 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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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...

[OrDonc]

Re

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Leelya]

Génial !

Merci à tous et pour tout !