JBARBE
XLDnaute Barbatruc
Bonjour à tous,
Il y a quelques années j'ai fait une macro ( que je trouve trop compliquée) pour un pense bête automatisé
Suivant une date en colonne B!
Les dates non renouvelées en colonne E ( exemple 365 jours pour 1 an renouvelées automatiquement) sont
envoyées dans la feuille "Date_Terminée" !
La ligne concernée se colorie en rouge + un msgbox pour la date du jour !
La ligne concernée se colorie en jaune + un msgbox pour la date du jour -1 !
La ligne concernée se colorie en vert + un msgbox pour la date du jour >1 et =< 5!
La colonne F indique le nombre de jours restant en rouge !
Ce code ne fonctionne pas bien et ne me satisfait pas !
Merci pour vos suggestions !
Il y a quelques années j'ai fait une macro ( que je trouve trop compliquée) pour un pense bête automatisé
Suivant une date en colonne B!
Les dates non renouvelées en colonne E ( exemple 365 jours pour 1 an renouvelées automatiquement) sont
envoyées dans la feuille "Date_Terminée" !
La ligne concernée se colorie en rouge + un msgbox pour la date du jour !
La ligne concernée se colorie en jaune + un msgbox pour la date du jour -1 !
La ligne concernée se colorie en vert + un msgbox pour la date du jour >1 et =< 5!
La colonne F indique le nombre de jours restant en rouge !
Code:
Dim i As Integer
Dim k As Integer
Dim h As Integer
Sub Selectionner()
Application.ScreenUpdating = False
Sheets("Date_En_Cours").Select
Range("B2").Select
For i = 1 To 10000 ''''' debut i
If Cells(i, 2).Value = "" Then Exit For
If Cells(i, 1).Interior.ColorIndex = xlNone Then
Range(Cells(i, 1), Cells(i, 6)).Interior.ColorIndex = 24
ElseIf Cells(i, 2).Value = Date + 1 Then
MsgBox Cells(i, 1) & " à venir le " & Cells(i, 2) & " à Heure " & Cells(i, 3) & " J" & Date - Cells(i, 2)
Range(Cells(i, 1), Cells(i, 6)).Interior.ColorIndex = 6
Cells(i, 6).Value = Date - Cells(i, 2)
Cells(i, 6).Font.ColorIndex = 3
Cells(i, 6).Font.Bold = True
Cells(i, 6).Interior.ColorIndex = 6
ElseIf Cells(i, 2).Value = Date + 2 Or Cells(i, 2).Value = Date + 3 Or Cells(i, 2).Value = Date + 4 Or Cells(i, 2).Value = Date + 5 Then
MsgBox Cells(i, 1) & " à venir le " & Cells(i, 2) & " à Heure " & Cells(i, 3) & " J" & Date - Cells(i, 2)
Range(Cells(i, 1), Cells(i, 6)).Interior.ColorIndex = 8
Cells(i, 6).Value = Date - Cells(i, 2)
Cells(i, 6).Font.ColorIndex = 3
Cells(i, 6).Font.Bold = True
Cells(i, 6).Interior.ColorIndex = 8
ElseIf Cells(i, 2).Value < Date And Cells(i, 5).Value = "" Then
Range(Cells(i, 1), Cells(i, 4)).Copy
Sheets("Date_Terminée").Select
Cells(2, 2).Select
For k = 1 To 10000 ''''' debut k
If Cells(k, 2).Value = "" Then
ActiveSheet.Paste
Application.CutCopyMode = False
Range(Cells(k, 2), Cells(k, 6)).Interior.ColorIndex = xlNone
Sheets("Date_En_Cours").Select
Exit For
Else
Cells(k + 1, 2).Select
End If
Next k ''''' fin k
Range("B2").Select
For h = 1 To 1000 ''''' debut h
If Cells(h, 2).Value = "" Then Exit For
If Cells(h, 2).Value < Date Then
Cells(h, 2).EntireRow.Delete
Exit For
Else
Cells(h + 1, 2).Select
End If
Next h ''''' fin h
ElseIf Cells(i, 2).Value = Date Then
MsgBox Cells(i, 1) & " AUJOURD'HUI le " & Cells(i, 2) & " à Heure " & Cells(i, 3)
Range(Cells(i, 1), Cells(i, 4)).Interior.ColorIndex = 3
Cells(i, 6).Value = Date - Cells(i, 2)
Cells(i, 6).Font.ColorIndex = 3
Cells(i, 6).Font.Bold = True
Cells(i, 6).Interior.ColorIndex = 8
ElseIf Cells(i, 2).Value < Date And Cells(i, 5).Value = "" Then
Range(Cells(i, 1), Cells(i, 4)).Interior.ColorIndex = 35
Cells(i, 6).Clear
Cells(i, 3).Clear
ElseIf Cells(i, 2).Value < Date And Cells(i, 5).Value <> "" Then
Cells(i, 2).Value = Cells(i, 2) + Cells(i, 5)
Cells(i, 6).Clear
Cells(i, 3).Clear
Range(Cells(i, 1), Cells(i, 4)).Interior.ColorIndex = xlNone
ElseIf Cells(i, 2).Value < DateSerial(Year(Date), Month(Date), Day(Date) + 15) Then
Cells(i, 6).Value = Cells(i, 2) - Date
Cells(i, 6).Font.ColorIndex = 3
Cells(i, 6).Font.Bold = True
Else
Cells(i + 1, 2).Select
End If
Next i ''''' fin i
Application.ScreenUpdating = True
End Sub
Ce code ne fonctionne pas bien et ne me satisfait pas !
Merci pour vos suggestions !