XL 2013 incerer des cellules sur une ligne en forçant une date entre deux dates

Dicas · 11 Octobre 2015

Bonjour le forum !!
J'ai un Agenda perpétuel qui ne liste par principe que les mardi (qui correspondent à des dates de réunions).
cet agenda couvre 80% de mes besoins; Mais !! il y a des exceptions !
Des dates spéciales peuvent s'y incérer dans la colonne "Dates exception." entre deux 'mardi'. La date '29/10/2014' incérée, la suivante glisse alors d'une ligne vers le bas (les colonnes A à F sont consacrées à mes dates, les autres de G à N sont consacrées aux commentaires).
Si la date exceptionnelle doit être annulée, l'inverse est vrai.
Jusque la ça va !
C'est après que se pose le Pb. Je ne sais pas comment faire pour que les autres cellules G5 à N5 s'incèrent en même temps à l'ajout ou disparaissent à la suppression !!???
Les manips nécessaires sont compliquées et cachent des pièges...
Avez-vous un truc, une inspiration ??

job75 · 11 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Bonjour Dicas,

Voyez le fichier joint.

1) Trois de vos colonnes me paraissant totalement inutiles, je les ai supprimées.

2) Avant toute insertion de ligne, formule en A3 à tirer vers le bas :

Code:

=A$2+7*SOMMEPROD(N(JOURSEM(A$2:A2)=3))

3) La macro pour l'insertion/suppression de ligne par double-clic :

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
  If .Column > 1 Or .Row < 3 Or Not IsDate(.Value) And .Interior.ColorIndex <> 50 Then Exit Sub
  Cancel = True
  If .Interior.ColorIndex = 50 Then
    .EntireRow.Delete
  Else
    .EntireRow.Insert
    .Offset(-1).Interior.ColorIndex = 50 'vert
    .Offset(-1, 1) = "=ROW()-1"
    .Offset(-1).Select
  End If
End With
End Sub

4) La macro pour le contrôle des dates entrées en colonne A :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, i&, dat As Date
t = Intersect([A:B], Me.UsedRange.EntireRow) 'au moins 2 cellules
For i = 2 To UBound(t)
  If IsDate(t(i, 1)) Then
    If Int(t(i, 1)) <= Int(dat) Then MsgBox "Date refusée !", 48: Application.Undo: Exit Sub
    dat = t(i, 1)
  End If
Next
End Sub

Les dates doivent être en ordre strictement croissant sinon l'entrée est annulée.

A+

job75 · 12 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Bonjour Dicas, le forum,

Pour éviter toute erreur il est nécessaire de protéger la feuille.

Dans Thisworkbook :

Code:

Private Sub Workbook_Open()
Feuil1.Protect "TOTO", UserInterfaceOnly:=True 'mot de passe à adapter
Me.Saved = True 'évite l'invite si fermeture sans modification
End Sub

La macro Worksheet_Change :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, i&, dat As Date
t = Intersect([A:B], Me.UsedRange.EntireRow) 'au moins 2 cellules
For i = 2 To UBound(t)
  If IsDate(t(i, 1)) Then
    If Int(t(i, 1)) <= Int(dat) Then MsgBox "Date refusée !", 48: Application.Undo: Exit Sub
    dat = t(i, 1)
  End If
Next
'---déverrouillage-verrouillage---
Cells.Locked = False
On Error Resume Next 's'il n'y a pas encore de formules
Cells.SpecialCells(xlCellTypeFormulas).Locked = True
End Sub

Seules les cellules avec formule sont verrouillées.

On peut toujours les tirer vers le bas en colonne A.

Fichier (2).

Bonne journée.

job75 · 12 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Re,

Si l'on veut pouvoir formater les cellules malgré la protection :

Code:

Private Sub Workbook_Open()
Feuil1.Protect "TOTO", UserInterfaceOnly:=True, AllowFormattingCells:=True
Me.Saved = True 'évite l'invite si fermeture sans modification
End Sub

Et avec ceci toute ligne > 2 ne contenant pas de formules sera supprimée par le double-clic :

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
  If .Column > 1 Or .Row < 3 Then Exit Sub
  Cancel = True
  If .HasFormula Then
    .EntireRow.Insert
    .Offset(-1).Interior.ColorIndex = 15 'gris clair
    .Offset(-1, 1) = "=ROW()-1"
    .Offset(-1).Select
  Else
    .EntireRow.Delete
  End If
End With

Je mets les dates exceptionnelles en gris clair (code 15) pour pouvoir retrouver facilement cette couleur si jamais on la modifie.

Fichier (3).

A+

Dicas · 13 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Job75 !! Bonjour !!!

De toute évidence, avec mes connaissances, je ne peux pas rivaliser !
C'est la solution, et en beaucoup plus synthétique, qu'il me fallait !
Le passage à mon appli est parfait !
Il ne me reste plus qu'à essayer de comprendre et donc apprendre ... encore et encore ...

Merci !!

Dicas · 16 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Job75 !! bonjour !!

J'ai intégré le code à mon appli sans difficulté (sauf la dernière modif à propos des lignes que je garde pour plus tard)et je n'ai pas eu de Pb jusqu'à ce que j'y face une nouvelle correction (en relation avec un document de synthèse qui est composé à partir de tout ceci); Et là, j'ai un ennui !

L'insertion ne répond plus ! Je l'avais déjà eu au cours de l'installation et j'avais trouvé la parade, mais là, je suis à sec !
Un coup de main me serait utile

un extrait de mon appli permettra d'y voir clair !
Merci !

job75 · 16 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Bonjour Dicas,

Un fichier .xlsx ne peut pas contenir de macro, nous n'irons donc pas loin

A+

Dicas · 16 Octobre 2015

Re : incerer des cellules sur une ligne en forçant une date entre deux dates

Re... Bonjour !!!

Eh! désolé, je n'ai pas envoyé le bon fichier et comme :
1 - L'extrait que j'avais préparé reste trop gros.
2 - Qu'en l'ouvrant à l'instant-même, il a répondu à mes sollicitations... Je me demande...

Je remets le tout sur l'établi je cherche et si nécessaire nous nous retrouverons plus tard ..
Merci encore !

XL 2013 incerer des cellules sur une ligne en forçant une date entre deux dates

Dicas

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Dicas

XLDnaute Junior

Dicas

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

Dicas

XLDnaute Junior

Discussions similaires