[Toutes versions] pense bête en VBA

1 pièce(s) jointe(s)

pense bête en VBA

Bonjour,

J'ai un pense bête avec une feuille " Date_En_Cours" et une autre feuille avec " Date_Terminée " !

Je voudrais que les dates terminées (colonnes de A à G)se retrouvent dans la feuille " Date_Terminée" sauf lorsque dans la colonne E il y a un chiffre ( exemple 7 pour une semaine qui reconduit la date d'une semaine) !

D'autre part, en plus d'avoir une boîte de dialogue m'indiquant les dates à venir( date - 5), une couleur est associée !

J'ai fait une macro qui fonctionne, mais je pense qu'il y a plus simple !

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
Sub Selection_Premier()
Dim j As Integer
Application.ScreenUpdating = False
Filtre
Sheets("Date_En_Cours").Select
Range("B2").Select
For j = 2 To Range("A1").End(xlDown).Row ''''' debut j
If Cells(j, 2).Value = "" Then Exit For
If Cells(j, 8).Value = 1 Then
Cells(j + 1, 2).Select
Else
Selectionner
Cells(j + 1, 2).Select
End If
Next j
Range("H:H").ClearContents
Filtre
Application.ScreenUpdating = True
End Sub
 
Sub Selectionner()
Application.ScreenUpdating = False
Dim i As Integer
Dim k As Integer
Dim h As Integer
Sheets("Date_En_Cours").Select
Range("B2").Select
For i = 2 To Range("A1").End(xlDown).Row ''''' debut i
If Cells(i, 2).Value = "" Then Exit For
Cells(i, 7).FormulaR1C1 = _
        "=IF(WEEKDAY(RC[-5],2)=1,""Lundi"",IF(WEEKDAY(RC[-5],2)=2,""Mardi"",IF(WEEKDAY(RC[-5],2)=3,""Mercredi"",IF(WEEKDAY(RC[-5],2)=4,""Jeudi"",IF(WEEKDAY(RC[-5],2)=5,""Vendredi"",IF(WEEKDAY(RC[-5],2)=6,""Samedi"",IF(WEEKDAY(RC[-5],2)=7,""Dimanche"","""")))))))"
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 And Cells(i, 8).Value = "" Then
 Cells(i, 8).Value = 1
    MsgBox Cells(i, 1) & "  à venir " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3) & "  J" & Date - Cells(i, 2)
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 6
    Cells(i, 6).Value = Date - Cells(i, 2)
ElseIf Cells(i, 2).Value = Date + 2 And Cells(i, 8).Value = "" Then
 Cells(i, 8).Value = 1
    MsgBox Cells(i, 1) & "  à venir " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3) & "  J" & Date - Cells(i, 2)
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 8 ''' Bleue
    Cells(i, 6).Value = Date - Cells(i, 2)
ElseIf Cells(i, 2).Value = Date + 3 And Cells(i, 8).Value = "" Then
 Cells(i, 8).Value = 1
    MsgBox Cells(i, 1) & "  à venir " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3) & "  J" & Date - Cells(i, 2)
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 8 ''' Bleue
    Cells(i, 6).Value = Date - Cells(i, 2)
ElseIf Cells(i, 2).Value = Date + 4 And Cells(i, 8).Value = "" Then
 Cells(i, 8).Value = 1
    MsgBox Cells(i, 1) & "  à venir " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3) & "  J" & Date - Cells(i, 2)
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 8 ''' Bleue
    Cells(i, 6).Value = Date - Cells(i, 2)
ElseIf Cells(i, 2).Value = Date + 5 And Cells(i, 8).Value = "" Then
 Cells(i, 8).Value = 1
    MsgBox Cells(i, 1) & "  à venir " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3) & "  J" & Date - Cells(i, 2)
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 8 ''' Bleue
    Cells(i, 6).Value = Date - Cells(i, 2)
 
ElseIf Cells(i, 2).Value > Date + 5 Then
    Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 24 ''' Violet
ElseIf Cells(i, 2).Value < Date And Cells(i, 5).Value = "" And Cells(i, 8).Value = "" Then
Cells(i, 8).Value = 1
  MsgBox Cells(i, 1) & " Date Terminée "
     Range(Cells(i, 1), Cells(i, 7)).Copy
     Sheets("Date_Terminée").Select
     Cells(2, 2).Select
       For k = 2 To 30000 ''''' debut k
         If Cells(k, 2).Value = "" Then
         ActiveSheet.Paste
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
         Application.CutCopyMode = False
         Range(Cells(k, 2), Cells(k, 8)).Interior.ColorIndex = xlNone  ''''' Blanc
         Sheets("Date_En_Cours").Select
         Exit For
         Else
         Cells(k + 1, 2).Select
         End If
         Next k  ''''' fin k
        Range("B2").Select
         For h = 2 To Range("A1").End(xlDown).Row ''''' debut h
         If Cells(h, 2).Value = "" Then Exit For
          If Cells(h, 2).Value < Date Then
        Cells(h, 2).EntireRow.Delete
        Exit Sub
         'Exit For
        Else
         Cells(h + 1, 2).Select
         End If
         Next h ''''' fin h
ElseIf Cells(i, 2).Value = Date And Cells(i, 8).Value = "" Then
    MsgBox Cells(i, 1) & "  AUJOURD'HUI " & Cells(i, 7) & " le  " & Cells(i, 2) & "  à Heure  " & Cells(i, 3)
     Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 3 '''' rouge
     Cells(i, 6).Value = "0"
     Cells(i, 8).Value = 1
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 <> "" And Cells(i, 8).Value = "" Then
 MsgBox Cells(i, 1) & " Date Terminée & à plus tard "
Cells(i, 2).Value = Cells(i, 2) + Cells(i, 5)
Cells(i, 6).Clear
Cells(i, 3).Clear
Cells(i, 8).Value = 1
Range(Cells(i, 1), Cells(i, 6)).Interior.ColorIndex = 24 ''''' Violet
Else
Cells(i + 1, 2).Select
End If
     Next i ''''' fin i
Application.ScreenUpdating = True
End Sub
 
Sub Filtre()
 
    ActiveWorkbook.Worksheets("Date_En_Cours").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Date_En_Cours").AutoFilter.Sort.SortFields.Add Key _
        :=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Date_En_Cours").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Merci à l'avance !

Bonjour,

Peux-tu mettre le classeur correspondant à ton image en pièce jointe, ce sera plus facile.

1 pièce(s) jointe(s)

C'est fait :

Ma macro est peut-être trop simple. Tu as l'air de faire beaucoup de choses dans la tienne :)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub test()
Dim C As Range, Sh As Worksheet, Ligne As Integer
Set Sh = Sheets("Date_Terminée")
With Sheets("Date_En_Cours")
    For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
        If C.Offset(, 1) < Date Then
            If C.Offset(, 4) > 0 Then
                C.Offset(, 1) = C.Offset(, 1) + C.Offset(, 4)
            Else
                Ligne = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row + 1
                .Range(C, C.Offset(, 6)).Copy
                Sh.Cells(Ligne, 2).PasteSpecial xlPasteValues
            End If
        End If
    Next C
End With
End Sub

Merci de votre réponse !

La ligne concernant la date d'aujourd'hui est supprimée ( sauf quant il y a en colonne E un nombre ( 7 pour une semaine pour le renouvellement))dans la feuille " Date_En_Cours " pour être mise dans la Feuille "Date_Terminée" !

De plus de la Date J - 5 à la Date aujourd'hui il y a une coloration dans la ligne (colonne A à G ) !

Les lignes concernées sont remontées en tête ( macro > Filtre ), mais je suis obligé de cliquer une seconde fois pour y arriver ! Là il y a un problème non résolu !

Ainsi cette macro est si complexe !

Merci!

Citation:

Les lignes concernées sont remontées en tête ( macro > Filtre ), mais je suis obligé de cliquer une seconde fois pour y arriver ! Là il y a un problème non résolu !

En faisant un tri sur la date ? Pour les couleurs, tu peux utiliser une lise en forme conditionnelle.

1 pièce(s) jointe(s)

Le tri sur la date avait été oublié !

J'ai utilisé la forme conditionnelle pour les couleurs mais l'ensemble reste complexe !

Malgré tout, maintenant le programme fonctionne parfaitement !