Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' attribuer la clef suivante
Dim max As Long
'si la première cellule vide de la colonne A est celle sur laquelle on a double cliqué
If Target.Address = Range("a" & Rows.Count).End(xlUp).Offset(1).Address Then
Cancel = True
'on recherche le max des clefs au dessus de la cellule vide et on rajoute 1
max = Application.WorksheetFunction.max(Range("a3:a" & Target.Row - 1)) + 1
'on copie la cellule au dessus de target sur target
'permet aussi de recopier le format
Target.Offset(-1).Copy Target
'remplacer la valeur de target par max
Target = max
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rgColonneT As Range, xcell As Range, rgTrouve As Range
' en cas d'erreur, on réactive l'interception des évènements et on quitte
On Error GoTo Erreur_001
' on bloque l'interception des évènements
Application.EnableEvents = False
' on bloque l'affichage
Application.ScreenUpdating = False
' on recherche les valeurs de la colonne T qui ont changé
Set rgColonneT = Intersect(Target, Columns("t:t"))
'Pour chaque cellule qui a changé
For Each xcell In rgColonneT.Cells
If xcell = "NON" Then
'on recherche la clef de la la ligne correspondant à xcell
' dans la colonne F de la feuille "PRISE A CHARGE"
With Worksheets("PRISE A CHARGE")
Set rgTrouve = Nothing
Set rgTrouve = .Columns("f:f").Find(what:=Range("a" & xcell.Row), _
LookIn:=xlValues, lookat:=xlWhole)
If Not rgTrouve Is Nothing Then
' on a trouvé la clef => on efface la ligne correspondante
.Rows(rgTrouve.Row).Delete
End If
End With
ElseIf xcell = "Prise à charge" Then
'on recherche la clef de la la ligne correspondant à xcell
' dans la colonne F de la feuille "PRISE A CHARGE"
With Worksheets("PRISE A CHARGE")
Set rgTrouve = Nothing
Set rgTrouve = .Columns("f:f").Find(what:=Range("a" & xcell.Row), _
LookIn:=xlValues, lookat:=xlWhole)
If Not rgTrouve Is Nothing Then
' on a trouvé la clef => on efface la ligne correspondante
.Rows(rgTrouve.Row).Delete
End If
' on recherche la première ligne vide dans la feuille "PRISE A CHARGE"
Set rgTrouve = .Range("f" & .Rows.Count).End(xlUp).Offset(1)
' on copie la ligne de la feuille "LISTE ACHAT" vers la feuille "PRISE A CHARGE"
Range("a" & xcell.Row & ":t" & xcell.Row).Copy rgTrouve
' formatage
With rgTrouve.Resize(, Range("a1:t1").Columns.Count)
.Value = .Value
.FormatConditions.Delete
.Validation.Delete
.Interior.ColorIndex = xlColorIndexNone
.Borders.LineStyle = msoLineSingle
End With
.Range("a" & rgTrouve.Row & ":e" & rgTrouve.Row).Borders.LineStyle = msoLineSingle
End With
End If
Next xcell
Erreur_001:
' on réactive l'interception des évènements
Application.EnableEvents = True
' on bloque l'affichage
Application.ScreenUpdating = False
End Sub