Ajout et supp de données par proc événementielle

[antiphot]

Bonjour à toutes et à tous

Dans un tableau, j'ai une colonne "R" dans laquelle je rentre des dates.

Une procédure événementielle dans la feuille "2008" vérifie que les valeurs rentrées dans cette colonne sont bien au format date et copie la valeur activecell.offset(0,-17), (soit la colonne A) dans la colonne 1 de la feuille "Donnees".

Mon souhait;

Si j'efface une des dates rentrées dans ma colonne "R" de la feuille "2008", j'aimerais effacer la valeur correspondant à activecell.offset(0,-17) dans la colonne 1 de la feuille "Donnees" , sauf si cette valeur.offset(0,1) = "Envoyé"

Ci-joint mon fichier exemple

 

[job75]

Re : Ajout et supp de données par proc événementielle

Bonjour antiphot,

Voyez si ce code vous convient :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 18 Or Target.Cells.Count > 1 Then Exit Sub
Dim lig, temp As Long
lig = 0
On Error Resume Next
lig = Application.Match(Target.Offset(0, -17), Sheets("Donnees").Range("A:A"), 0)
If IsDate(Target) And lig = 0 Then
    temp = Application.CountA(Sheets("Donnees").Range("A:A")) + 1
    Sheets("Donnees").Cells(temp, 1) = Target.Offset(0, -17)
End If
If lig Then
    With Sheets("Donnees").Cells(lig, 1)
        If Target = "" And .Offset(0, 1) <> "Envoyé" Then .EntireRow.Delete
    End With
End If
End Sub

J'ai rajouté un test pour l'entrée des données en feuille Donnees de manière que chaque entrée ne soit faite qu'une fois.

A+

 

[antiphot]

Re : Ajout et supp de données par proc événementielle

Bonjour Job75

Merci pour tout c'est Nickel et cela correspond tout à fait à ce que j'attendais

 

[job75]

Re : Ajout et supp de données par proc événementielle

Re,

La macro précédente a été faite un peu vite, il y avait des imperfections.

J'ai ajouté aussi des améliorations : annulation des entrées si plusieurs cellules modifiées simultanément ou si l'entrée n'est pas une date, tri de la feuille Données.

Voici la nouvelle mouture :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("R4:R10000")) Is Nothing Then Exit Sub
Application.EnableEvents = False [COLOR="Red"]'désactive l'action des évènements[/COLOR]
On Error Resume Next [COLOR="Red"]'contrôle d'erreur[/COLOR]
If Target.Cells.Count > 1 Then Application.Undo: GoTo 1 [COLOR="Red"]'annule si plusieurs cellules modifiées simultanément[/COLOR]
Dim lig As Long
lig = 0
With Sheets("Donnees")
lig = Application.Match(Target.Offset(0, -17), .Range("A:A"), 0)
[COLOR="Red"]'pour l'entrée d'une donnée[/COLOR]
If lig = 0 Then
  If Target <> "" And Not IsDate(Target) Then Application.Undo: GoTo 1 [COLOR="Red"]'annule l'entrée si ce n'est pas une date[/COLOR]
  .Cells(Application.CountA(.Range("A:A")) + 1, 1) = Target.Offset(0, -17) [COLOR="Red"]'écriture en feuille Donnes[/COLOR]
  .Range("A:B").Sort Key1:=.Range("A1"), Order1:=xlAscending [COLOR="Red"]'tri ascendant feuille Donnees[/COLOR]
End If
[COLOR="Red"]'pour l'effacement[/COLOR]
If Target = "" And .Cells(lig, 1).Offset(0, 1) <> "Envoyé" Then .Rows(lig).Delete [COLOR="Red"]'supprime la ligne[/COLOR]
End With
1 Application.EnableEvents = True [COLOR="Red"]'réactive l'action des évènements[/COLOR]
End Sub

A+