Incrémenter valeur par double-clic [RÉSOLU]

[elisium]

Bonjour à toutes et a tous,
J'ai actuellement en colonne A, un code qui me colle la date du jour par double clic.
Je recherche à incrémenter en même temps la valeur de la colonne B.
Je joins un fichier pour exemple de mes besoins.
Merci par avance pour votre aide.

Cdt.

 

[gilbert_RGI]

Re : Incrementer valeur par doubleclic

Bonjour,

comme ceci

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim chaine As String, nb As Integer, vchaine As String, maval As Integer
    If Target.Column = 1 Then
        Target.Value = Date
        Cancel = True
        chaine = Target.Offset(-1, 1)
        nb = InStr(1, chaine, "-")
        vchaine = Left(chaine, nb)
        maval = Right(chaine, Len(chaine) - nb)
        Target.Offset(0, 1) = vchaine & CInt(maval) + 1
    End If
End Sub

 

[elisium]

Re : Incrementer valeur par doubleclic

Merci Gilbert
Je viens de tester c parfait.
Bonne journée.

 

[gilbert_RGI]

Re : Incrémenter valeur par double-clic [RÉSOLU]

Attention il peut se produire une erreur si il y a la cellule (-1,1) vide

voilà une ligne supplémentaire pour remédier à ça

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim chaine As String, nb As Integer, vchaine As String, maval As Integer
    If Target.Column = 1 Then
        Target.Value = Date
        Cancel = True
        chaine = Target.Offset(-1, 1)
        If chaine = "" Then MsgBox "Erreur": Exit Sub
        nb = InStr(1, chaine, "-")
        vchaine = Left(chaine, nb)
        maval = Right(chaine, Len(chaine) - nb)
        Target.Offset(0, 1) = vchaine & CInt(maval) + 1
    End If
End Sub

 

[Si...]

Re : Incrémenter valeur par double-clic [RÉSOLU]

salut

autre proposition pour le doubleclic sur la première cellule non vide de la colonne

Private Sub Worksheet_BeforeDoubleClick(ByVal R As Range, Cancel As Boolean)
  If R.Address <> [A65000].End(xlUp)(2).Address Then Exit Sub
  Dim s
  s = Split(R(0, 2), "-")
  R = Date: R(1, 2) = s(0) & "-" & s(1) + 1
  R(2, 1).Select
End Sub