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 129 130 131 132 133 134 135 136 137 138 139 140 141
|
Private LigneDeDate
Private compteurFeuille
Private ColonneDuNom
Private compteurDeColonneDuJour
Private Sub CmBAnnuler_Click()
Unload Me
End Sub
Private Sub ComboDate_Change()
ComboDate = CDate(ComboDate)
End Sub
Private Sub UserForm_Initialize()
Dim Cell As Range
With Sheets("FeuilleDeTravail")
For Each Cell In .Range("J2:J" & .Range("J65536").End(xlUp).Row)
ComboNom.AddItem (Cell)
Next
For Each Cell In .Range("G2:G" & .Range("G65536").End(xlUp).Row)
ComboDate.AddItem (Cell)
Next
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Unload Me
End Sub
Private Sub CmbValider_Click()
If ComboNom = "" Then
MsgBox " le nom de l'utilisateur n'est pas documenté "
Exit Sub
End If
If ComboDate = "" Then
MsgBox " la date de réservation n'est pas documentée "
Exit Sub
End If
For compteurFeuille = 1 To Worksheets.Count
If Sheets(compteurFeuille).Name <> "Menu" And Sheets(compteurFeuille).Name <> "FeuilleDeTravail" And Sheets(compteurFeuille).Name <> "Cadre" And Worksheets(compteurFeuille).Name <> "Jours ouvrés" Then
'MsgBox Sheets(compteurFeuille).Name
LigneDeDate = Application.WorksheetFunction _
.Match(CLng(CDate(ComboDate)), Worksheets(compteurFeuille).Range("A1:A368"), 0)
On Error GoTo GestionDesErreurs
ColonneDuNom = Application.WorksheetFunction _
.Match(ComboNom, Worksheets(compteurFeuille).Range("B" & LigneDeDate & ":Y" & LigneDeDate), 0)
On Error GoTo 0
' effacement des resa jours précédents
If ColonneDuNom = 1 And Worksheets(compteurFeuille).Cells(LigneDeDate - 1, 25).Interior.ColorIndex = 35 Then
EffacementRésaJourAvant
End If
' Effacement de la résa du jour
EffacementResaDuJour
If compteurDeColonneDuJour = 25 Then
EffacementResaDesJoursAprès
End If
MsgBox "Suppression effectué pour M: " & ComboNom & " pour la date du : " & CDate(ComboDate) & " pour l'objet : " & Sheets(compteurFeuille).Name
Unload Me
Exit Sub
Autre:
End If
Next
MsgBox " pas de réservation trouvée en date du : " & CDate(ComboDate) & " pour M : " & ComboNom & " ."
Unload Me
GestionDesErreurs:
If Err = 1004 Then
Err = 0
Resume Autre
End If
End Sub
Sub EffacementRésaJourAvant()
Dim compteurDeColonne As Byte
Dim LigneAAnalyser As Integer
With Sheets(compteurFeuille)
For LigneAAnalyser = LigneDeDate - 1 To 4 Step -1
compteurDeColonne = 25
Do Until compteurDeColonne = 1
If .Cells(LigneAAnalyser, compteurDeColonne).Interior.ColorIndex <> 35 Then
Exit Sub
End If
If .Cells(LigneAAnalyser, compteurDeColonne) <> "" Then
If .Cells(LigneAAnalyser, compteurDeColonne) <> ComboNom Then
Exit Sub
ElseIf .Cells(LigneAAnalyser, compteurDeColonne) = ComboNom Then
Range(.Cells(LigneAAnalyser, compteurDeColonne), .Cells(LigneAAnalyser, 25)).Clear
If compteurDeColonne > 2 Then
Exit Sub
End If
End If
End If
compteurDeColonne = compteurDeColonne - 1
Loop
Next
End With
End Sub
Sub EffacementResaDuJour()
With Sheets(compteurFeuille)
For compteurDeColonneDuJour = ColonneDuNom + 1 To 25
If .Cells(LigneDeDate, compteurDeColonneDuJour).Borders(xlEdgeRight).LineStyle = xlContinuous Then
Range(.Cells(LigneDeDate, ColonneDuNom + 1), .Cells(LigneDeDate, compteurDeColonneDuJour)).Clear
Exit Sub
End If
Next
End With
End Sub
Sub EffacementResaDesJoursAprès()
Dim compteurDeColonne As Byte
Dim LigneAAnalyser As Integer
With Sheets(compteurFeuille)
For LigneAAnalyser = LigneDeDate + 1 To 368 Step 1
compteurDeColonne = 2
If .Cells(LigneAAnalyser, compteurDeColonne).Interior.ColorIndex <> 35 Then
Exit Sub
End If
If .Cells(LigneAAnalyser, compteurDeColonne) <> "" Then
If .Cells(LigneAAnalyser, compteurDeColonne) <> ComboNom Then
Exit Sub
ElseIf .Cells(LigneAAnalyser, compteurDeColonne) = ComboNom Then
Do Until compteurDeColonne = 26
If .Cells(LigneAAnalyser, compteurDeColonne).Borders(xlEdgeRight).LineStyle = xlContinuous Then
Range(.Cells(LigneAAnalyser, 2), .Cells(LigneAAnalyser, compteurDeColonne)).Clear
End If
compteurDeColonne = compteurDeColonne + 1
Loop
If compteurDeColonne < 25 Then
Exit Sub
End If
End If
End If
Next
End With
End Sub |
Partager