pense bête en VBA

**jbchb** · 03/06/2012, 12h03

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 :

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

pense bête en VBA [Toutes versions]

Macros et VBA Excel

Mode arborescent

Discussions similaires

Partager

Partager