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