Pas appliquer 1 "sub" si les cellules ont une date inférieure à aujourdhui
Bonsoir,
J'ai un classeur que je dois en très grande partie à BsAlv et qui fonctionne parfaitement sauf sur 1 seul point :
- Sur les lignes 3, 7, 11, etc... de la feuille "Prévisions" ==> Si les dates sont inférieures ou égales à la date d'aujourd'hui, le sub M_PreBarrage dans le sub des "2mois" ci-dessous devrait ne pas s'appliquer. C'est à dire que les croix noires (ou l'effacement des croix) qui proviennent de la cellule J2 de la feuille "Paramètres", je voudrais que si les dates sont inférieures ou égales à la date d'aujourd'hui, les croix ne s'appliquent plus sur les cellules des lignes 4, 8, 12, etc...
Sub M_Nouvelle_Feuille_2Mois()
Dim Answ, sp, SHN As Worksheet
Dim SH As Worksheet: Set SH = Sheets("Prévisions") 'feuille cachée qui est modèle pour la feuille dès 2 mois
With SH
.Visible = msoTrue 'feuille visible qui est modèle pour la feuille dès 2 mois
MaDate = WorksheetFunction.EoMonth(Date, 1) 'mois prochain
If Month(MaDate) Mod 2 = 1 Then MaDate = WorksheetFunction.EDate(MaDate, 1) 'si mois prochain est impair, le mois suivant
Answ = Application.InputBox("Quelle est l'Année _ Mois du début" & vbLf & "Arrêter=0", "Nom de la nouvelle feuille", Format(MaDate, "yyyy mm"), Type:=2)
If Answ = False Or Answ = 0 Then Exit Sub
sp = Split(Answ)
If UBound(sp) <> 1 Then Exit Sub
MaDate = DateSerial(sp(0), sp(1), 1)
S = Replace(WorksheetFunction.Proper(WorksheetFunction.Text(MaDate, "[$-fr-fr]MMMYY ") & WorksheetFunction.Text(WorksheetFunction.EDate(MaDate, 1), "[$-fr-fr]MMMYY")), ".", "")
On Error Resume Next
Set SHN = Sheets(S)
If Not SHN Is Nothing Then MsgBox "feuille existe déjà", vbCritical: Exit Sub
On Error GoTo 0
'pour éviter le remplacement des formules par leur valeur, on met un mois dans le future ici et que tu peux ajuster plus tard !
Eoff 'bloquer les évents
Application.Calculation = xlCalculationManual 'bloquer calculation
.Range("_An").Value = Year(MaDate)
.Range("_mois").Value = WorksheetFunction.Text(MaDate, "[$-fr-fr]mmmm")
SH.Copy before:=SH 'créer une copie avant cette feuille
Application.Calculation = xlCalculationAutomatic
With ActiveSheet
.Name = S
'copier&coller les 5 formes de la ligne 1
For Each SHP In SH.Shapes
If SHP.AutoShapeType = msoShapeRoundedRectangle Or SHP.AutoShapeType = msoShapeRectangle Then
Set c = SHP.TopLeftCell
If c.Row = 1 Then
SHP.Copy 'copier le bouton "NEW"
M_Pause
M_Pause
N = .Shapes.Count
.Paste Range(c.Address) 'vers E1 de la nouvelle feuille
M_Pause
With .Shapes(N + 1)
.Left = SHP.Left
.Top = SHP.Top
End With
End If
End If
Next
bHS_NouvelleFeuille = True
M_PreBarrage ActiveSheet
For i = 4 To 40 Step 4
.Cells(i, 1).Resize(2).EntireRow.Locked = False
Next
For i = .Index - 1 To 1 Step -1
If Sheets(i).Range("C3").Value2 > .Range("C3").Value2 Then .Move before:=Sheets(i) 'déplacer la nouvelle feuille pour avoir une séquence normale des dates
Next
.Protect userinterfaceonly:=True, DrawingObjects:=False, Contents:=True, AllowInsertingRows:=True, AllowSorting:=True, AllowFiltering:=True
End With
Eon
'sh.Visible = msoFalse 'cacher la feuille "previsions"
Application.GoTo Range("A1") 'se positionner en haut de la nouvelle feuille
'MsgBox "Le nom de la feuille doit être sous la forme Déc25 Janv26", vbExclamation
End With
SH.Visible = xlVeryHidden 'msoTrue 'montrer la feuille "previsions"
M_DummyNames 'se débarrasser dès mauvaises plages nommées dû au "scope"
M_Synthese
End Sub Une idée de l'endroit où on peut agir avec les lignes de programmation pour arriver à ce résultat ?
Merci.
Bonne soirée.
Bonjour vodoraix,
Pour moi, c'est ICI
Sub M_PreBarrage(Optional SH As Worksheet)
'*************************************************************************************************
'chaque cellule aune propriété "ID" qui selon MS sert pour "identifying labels for webpages, blabla ..."
'bon, inappropriate use, je l'utilise pour sauvegarder le statut du "Croix" de la cellule, c'est plus pratique et plus rapide que les "comments"
'les statuts: 0 = sans croix, 1 = croix rouge, 2 : croix noir
'le temps pour lire ou écrire l'ID est négliable
'*****************************************************************************************************
' Procédure réagissant au Paramètre 1 ou autre en J2 de l'onglet Paramètres :
' 1 = mettre une croix
' Autre : enlever la croix
'*************************************************************************************************
Dim c, Arr, TBL, bPM, bImPair, i, j, j1, iWeekday, r, aBorders, bPrebarrage, Lundi, bDiagonal
t = Timer
If SH Is Nothing Then Set SH = ActiveSheet 'si on ne sait pas la feuille, c'est la feuille actuelle
If SH.Name Like "*## *##" Then 'nom de la feuille ressemble à cela
Application.ScreenUpdating = False
bPrebarrage = (Range("pre_barrage").Value = 1) ' on demande "pré-barrage"
TBL = Range("t_Semaine").Value2 'TS avec les propriétés des tâches
With SH
Set c = .Range("C2:AF41") 'votre plage
Arr = c.Value2 'lire vers matrice
For i = 3 To UBound(Arr) Step 4 'les lignes avec les tâches
Lundi = Arr(i - 1, 1) 'première cellule de la ligne dessus = lundi
' je voudrais que si les dates sont inférieures ou égales à la date d'aujourd'hui, les croix ne s'appliquent
' On exécute seulement si la date est supérieure à celle d'aujourdhui
If Lundi > Date And Len(Lundi) Then ' NEW - Tester ICI
bImPair = (WorksheetFunction.IsoWeekNum(Lundi) Mod 2 = 1) 'semaine impaire ?
j1 = Application.Max(1, (Date - Lundi) * 6 + 1) 'on ne touche pas aux colonnes d'une date dans le passé (6 colonnes par jour)
For j = 1 To UBound(Arr, 2) 'boucler horizontal
Debug.Print c.Cells(i, j).Address
bDiagonal = (TBL(j - bImPair * 30, 6) = 1) 'on veut le diagonal et le pré-barrage
If bDiagonal And c.Cells(i, j).ID = "" Then c.Cells(i, j).ID = "2" 'quand l'ID n'est pas connu, on commence avec un croix noir
M_Bordures c.Cells(i, j), Array(-bPrebarrage * Val(c.Cells(i, j).ID), xlNone, 0, c.Cells(i, j).Borders(xlDiagonalDown).LineStyle = xlNone) 'matrice avec la valeur de l'ID, linestyle "xlnone" et couleur "noir" du bordure
Next
End If
Next
End With
End If
bHS_NouvelleFeuille = False 'RAZ ce drapeau
End SubA+
Bonjour JExcelL2fr et merci beaucoup
C'est ce que j'avais mis dans mes 2 autres sujets précédents depuis 10 jours mais l'intervention de LouReeD dans celui-ci m'a mis un doute : https://forum.excel-pratique.com/excel/du-vba-qui-me-pose-probleme-sur-2-points-201605
J'avais essayé également dans ce sujet mais sans résultat ==> https://forum.excel-pratique.com/excel/1-bouton-qui-active-ou-desactive-un-sub-pour-enlever-toutes-l...
Donc c'est peut-être à ce niveau :
If SH.Name Like "*## *##" Then 'nom de la feuille ressemble à cela
Application.ScreenUpdating = FalseEn rajoutant, avant le "then", une autre condition ==> "And if.......... " (comparaison avec les dates des lignes 3, 7 , 11, etc...) sont supérieures strictement à la date d’aujourd’hui, alors on poursuit l'événement...
Qu'en pensez-vous ?
Merci
à bientôt
Re,
Je pense que oui, mais en développement, il suffit de modifier et de tester
Je ne sais pas "développer", sinon j'aurais testé depuis longtemps
Re,
Vous n'avez pas non plus l'esprit d'analyse alors
Pour tester, c'est simple (il faut le savoir)
- Un point d'arrêt [F9] sur une ligne (hors Dim)
- Pour avancer dans le code une fois le stop atteint -> [F8]
Je crois que vous me prêtez trop de compétences !
Déjà pour tester il faudrait que j'arrive à transformer ce :
"then", une autre condition ==> "And if.......... " (comparaison avec les dates des lignes 3, 7 , 11, etc...) sont supérieures strictement à la date d’aujourd’hui
==> En lignes de commandes exploitables...
Je ne sais pas écrire des lignes de commandes !
Merci quand même
Arf oui d'accord
If SH.Name Like "*## *##" And Lundi > Date ThenMais perso, j'aurais mis le code que j'ai donné au dessus
A+
J'avais déjà testé ton code mais les croix que je veux mettre manuellement, "rouges, noires et rien", ne s'affichent plus et j'ai un message ==>
Et j'ai ce message alors que je veux continuer à mettre des croix manuellement ==>
Or, j'aimerais que cette sub ci-dessous, fonctionne quelque soit la date ==>
Sub M_Bordures(Cellule As Range, Temp)
If Temp(0) <> 0 Or Temp(3) = False Then 'ignorer si on ne demande pas des bordures et on n'a pas une bordures
If Temp(0) <> 0 Then Temp(1) = xlContinuous 'statut 1 et 2 = croix
If Temp(0) = 1 Then Temp(2) = RGB(255, 0, 0) 'statut 1 est couleur "rouge"
Cellule.Borders(xlDiagonalDown).LineStyle = Temp(1)
Cellule.Borders(xlDiagonalUp).LineStyle = Temp(1)
If Temp(0) <> 0 Then
Cellule.Borders(xlDiagonalDown).Color = Temp(2)
Cellule.Borders(xlDiagonalUp).Color = Temp(2)
End If
End If
End SubMerci
à+
En réalité, même si pour la commande...
bPrebarrage = (Blad6.Range("pre_barrage").Value = 1)
...la valeur est autre que 1 alors je veux faire quand même pouvoir mettre des croix manuellement (croix noire, ou croix rouge ou rien)
Private Sub Clicquer(ByVal SH As Object, ByVal Target As Range, bCancel)
'********************************************
'la même procédure pour le double-clicque et le right-clicque
'donc dépendant de ton goût, utilise celui que tu préfères
'*********************************************
Dim lMax As Long
bCancel_HS = False 'handshake for the Cancel
If SH.Name Like "*## *##" Then 'nom de la feuille ressemble à cela (donc texte et 2 chiffres + espace + texte et 2 chiffres)
If Target.Cells.CountLarge = 1 Then
If Target.Row > 3 And Target.Row < 42 And Target.Column < 33 And Target.Value <> "" And Target.Value <> 0 Then 'double-clicque dans une ligne qui est un multiple de 4 +1 (donc 1,5,9,13,...)
bCancel_HS = True
Select Case Target.Row Mod 4
Case 0 'pour les lignes avec les tâches
'on utilise la propriété "RANGE.ID", voir explication dans la macro "M_PreBarrage"
'les possibilités sont 0 (sans croix, 1 (croix rouge) et 2 (croix noir)
bPrebarrage = (Blad6.Range("pre_barrage").Value = 1) ' on demande "pré-barrage"
If Not bPrebarrage Then
MsgBox "no pré-barrage", vbInformation, "Feuille Paramètres"
Else
With Target
lMax = Application.Max(.Offset(-1, -2).Resize(, 3)) 'quel jour ?
If lMax >= CLng(Date) Or 1 Then 'avant, on ne pouvait plus toucher aux cellules dans le passé, maintenant, on le peut ...
.ID = (Val(.ID) + 1) Mod 3 'statut suivant
M_Bordures Target, Array(-bPrebarrage * Val(Target.ID), xlNone, 0, Target.Borders(xlDiagonalDown).LineStyle = xlNone)
End If
End With
End If
Case 1 'pour les lignes avec les personnes (abbrev.)
With Target
B = Not .Font.Bold 'état "gras" de cette cellule
.Font.Bold = B 'état "gras" de cette cellule est inversé
.Font.Color = IIf(B, RGB(0, 0, 0), RGB(217, 217, 217)) 'couleur du texte = gris ou gris clair
.Font.Underline = IIf(B, xlUnderlineStyleSingle, xlNone) 'souligné ou pas
M_Synthese
End With
End Select
End If
Else
SH.Unprotect
End If
End If
End SubLa suite de ce sujet ==>
Merci
Bon w.e.