XL 2019 Colorié des zones par rapport a des critère de date si quelqu'un peut m'aider pour ce projet

[marsu-07]

Bonjour,
J'ai un soucis sur un classeur excel j'ai essayer en vba mais je n'ai pas réussi, en gros j'ai une colonne début de projet une autre fin de projet, et une autre état de projet( 1=en étude; 2=en cours et 3= terminé)

Je voudrais pouvoir colorier toutes les colonnes d'après qui sont "octobre 2021, novembre 2021 ..." selon les critères (colore en jaune si le projet dure de septembre 2021 à fevrier 2022 et si il est en cours ) merci de votre aide
Sachant que j'ai un soucis car si le projet commence en 2020 il ne reconnais pas la date du coup

Dites moi si vous voulais un exemple de la forme du classeur excel ...

Je vous met le code vba que j'ai essyer de créé:
"
Function chercherDerniereLigne() As Integer

Dim nbProjet As Integer
' chercher le nombre de projet
nbProjet = WorksheetFunction.CountA(Worksheets("iProjets chantiers (liste)").Range("N:N"))
chercherDerniereLigne = nbProjet
End Function
Sub ColorierJaune()

Dim c As Range
Dim c2 As Range
Dim c3 As Range
Dim Duree As Range
Dim position_debut As Integer
Dim position_fin As Integer
Dim nombre_colonne As Integer
Dim depart As String
Dim adresse As String
Dim colDeb As String
Dim fin As String
Dim colFin As String
Dim numprojet As Integer
Dim non As String
Dim arriver As String
Dim arr As String
Dim dep As String
Dim plage As String
Dim pos1 As Integer
Dim pos2 As Integer

numprojet = 1
For Each c In Worksheets("iProjets chantiers (liste)").Range("N2:N" & chercherDerniereLigne)
numprojet = numprojet + 1
adresse = c.Address
non = c.Value
fin = c.Offset(0, 1).Text

For Each c2 In Worksheets("iProjets chantiers (liste)").Range("Q1:AE1")

If c2.Text = c.Text Then
depart = c2.Address
End If
If c2.Text = fin Then
arriver = c2.Address
End If
Next
colDeb = Right(depart, Len(depart) - 1)
colFin = Right(arriver, Len(arriver) - 1)
pos1 = InStr(1, colDeb, "$")
pos2 = InStr(1, colFin, "$")
colDeb = Mid(colDeb, 1, pos1 - 1)
colFin = Mid(colFin, 1, pos2 - 1)
dep = colDeb & numprojet & ":"
arr = colFin & numprojet
plage = dep & arr
Range(plage).Interior.Color = vbYellow

Next

End Sub"

 

[AtTheOne]

Bonjour à tous, Bonjour @marsu-07

Pourquoi pas une Mise en Forme Conditionnelle ? :

Pour la 1ère plage de ton exemple
la cellule active étant D2, avec la formule : =($C2=2)*($A3<=D$1)*($B2>=D$1)
(Format remplissage jaune)
la MFC met en jaune les cellules qui réponde à tes critères (En cours et dates correspondant à la période)

Pour le deuxième tableau (D12:R16) il faudrait que tu précises tes critères

Amicalement
Alain

 

[marsu-07]

Bonjour à tous, Bonjour @marsu-07

Pourquoi pas une Mise en Forme Conditionnelle ? :

Pour la 1ère plage de ton exemple
la cellule active étant D2, avec la formule : =($C2=2)*($A3<=D$1)*($B2>=D$1)
(Format remplissage jaune)
la MFC met en jaune les cellules qui réponde à tes critères (En cours et dates correspondant à la période)

Pour le deuxième tableau (D12:R16) il faudrait que tu précises tes critères

Amicalement
Alain

Du coup j'ai fini le code VBA je t'avoue je vais pas tous rechanger, j'ai juste un problème, il marche mais si l'as date n'ai pas renseigner il s'arrête il y aurait-il une solution pour qu'il saute la ligne ?
Function chercherDerniereLigne() As Integer

Dim nbProjet As Integer
' chercher le nombre de projet
nbProjet = WorksheetFunction.CountA(Worksheets("iProjets chantiers (liste)").Range("B:B"))
chercherDerniereLigne = nbProjet
End Function

Function transformeDate(laDate As String) As Integer
Dim moisS As String
Dim anneeI As Integer
Dim dateFinal As Integer

moisS = Mid(laDate, 4, 2)
anneeI = Right(laDate, 2)

dateFinal = anneeI & moisS
transformeDate = dateFinal

End Function

Function couleur(etat As Integer) As String


Dim laCouleur As String

Select Case etat
Case 1
laCouleur = vbYellow
Case 2
laCouleur = vbRed
Case Else
laCouleur = vbGreen
End Select
couleur = laCouleur
End Function

Sub ColorierCalendrier()

Dim c As Range
Dim c2 As Range
Dim c3 As Range
Dim Duree As Range
Dim position_debut As Integer
Dim position_fin As Integer
Dim nombre_colonne As Integer
Dim depart As String
Dim adresse As String
Dim colDeb As String
Dim fin As String
Dim colFin As String
Dim numprojet As Integer
Dim non As String
Dim arriver As String
Dim arr As String
Dim dep As String
Dim plage As String
Dim pos1 As Integer
Dim pos2 As Integer
Dim uneDateDE As Integer
Dim limiteDE As Integer
Dim dateCellDE As String
Dim uneDateAR As Integer
Dim limiteAR As Integer
Dim dateCellAR As String
Dim LEtat As Integer


limiteDE = 2110
numprojet = 1
limiteAR = 2212

For Each c In Worksheets("iProjets chantiers (liste)").Range("R2:R" & chercherDerniereLigne)



adresse = c.Address
non = c.Value
fin = c.Offset(0, 1).Text

If fin = "" Then
If non = "" Then
numprojet = numprojet + 2
dateCellDE = c.Offset(1, 0).Value
uneDateDE = transformeDate(dateCellDE)
dateCellAR = c.Offset(1, 1).Value
uneDateAR = transformeDate(dateCellAR)
End If
End If
If fin = "" Then
If non <> "" Then
numprojet = numprojet + 1
dateCellDE = c.Offset.Value
uneDateDE = transformeDate(dateCellDE)
uneDateAR = uneDateDE
End If
End If
If fin <> "" Then
If non <> "" Then
numprojet = numprojet + 1
dateCellDE = c.Value
uneDateDE = transformeDate(dateCellDE)
dateCellAR = c.Offset(0, 1).Value
uneDateAR = transformeDate(dateCellAR)
End If
End If

For Each c2 In Worksheets("iProjets chantiers (liste)").Range("U1:AI1")

If c2.Text = c.Text Then
depart = c2.Address
End If

If c2.Text = fin Then
arriver = c2.Address
End If
Next

If uneDateDE < limiteDE Then
dep = "U" & numprojet & ":"
Else
colDeb = Right(depart, Len(depart) - 1)
pos1 = InStr(1, colDeb, "$")
colDeb = Mid(colDeb, 1, pos1 - 1)
dep = colDeb & numprojet & ":"
End If

If uneDateAR > limiteAR Then
arr = "AI" & numprojet
ElseIf uneDateAR < limiteDE Then
arr = "U" & numprojet
Else
colFin = Right(arriver, Len(arriver) - 1)
pos2 = InStr(1, colFin, "$")
colFin = Mid(colFin, 1, pos2 - 1)
arr = colFin & numprojet
End If
plage = dep & arr
Range(plage).Interior.Color = couleur(c.Offset(0, 2))
'nombre_colonne = ""
depart = ""
adresse = ""
colDeb = ""
fin = ""
colFin = ""
'numprojet = ""
non = ""
arriver = ""
arr = ""
dep = ""
plage = ""
'pos1 = ""
'pos2 = ""
'uneDateDE = ""
'limiteDE = ""
'dateCellDE = ""
'uneDateAR = ""
'limiteAR = ""
'dateCellAR = ""
Next

End Sub

 

[marsu-07]

Du coup dans le dossier il y a des cellules vides ou des cellules sans date de départ ou d'arriver c'est le reel problème si quelqu'un peu me modifier le code creer, je ne comprend pas pourquoi il ne fonctionne pas