Microsoft 365 Ajout d'une constante dans une cellule lors de la saisie

[steve74]

Bonjours à tous
Je souhaite pour mon boulot faire un fichier qui calcul automatiquement en ajoutant une constante issue d'une autre cellule.
Pour des raisons de confidentialité je ne peux pas soumettre de fichier
J'utilise des appareils qui me renvoient la valeur automatiquement, ces valeurs sont inscrites dans les cellules A2 à A50.
Ma cellule de réference est A1 (saisie par l'opérateur)

Exemple A1 = 11
Si la machine me renvoie en A2 la valeur 9. Je souhaiterai lors de la validation que le résultat soit remplacé par 20 (11+9)
Etc lors de la saisie A3...A3... etc

 

[JHA]

Bonjour à tous,

Tu ne peux pas le faire sans VBA.
Autre solution avec une colonne supplémentaire.

JHA

 

[steve74]

Bonsoir et merci

Bonjour à tous,

Tu ne peux pas le faire sans VBA.
Autre solution avec une colonne supplémentaire.

JHA

Bonsoir et Merci du retour rapide
J'avais pensé à la colonne sup mais je veux que mon fichier soit très polyvalent...en gros je place la valeur "0" si j'en n'ai pas besoin
Je suis à mon domicile avec un office 2010...Pouvez-vous me faire parvenir une version compatible ou un copier coller du vba ?
Encore merci
Steve

 

[steve74]

Rebonsoir à tous
Je précise ma demande (en bleu):
Je souhaite pour mon boulot faire un fichier qui calcul automatiquement en ajoutant une constante issue d'une autre cellule.
Pour des raisons de confidentialité je ne peux pas soumettre de fichier
J'utilise des appareils qui me renvoient la valeur automatiquement, ces valeurs sont inscrites dans les cellules A2 à A50.
Ma cellule de réference est A1 (saisie par l'opérateur)

Exemple A1 = 11
Si la machine me renvoie en A2 la valeur 9. Je souhaiterai lors de la validation que le résultat soit remplacé par 20 (11+9)
Etc lors de la saisie A3...A3... etc

La précision apporté est :
Si je nettoie la feuille par la suppression du contenu de la cellule je veux que la cellule soit vide. Et si le caractère est numérique on exécute l'opération.
J'ai trouvé la procédure évènementielle sur le changement

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Me.Range("A2:A50")) Is Nothing Then Exit Sub

'Ma_macro avec fonction If je pense

End Sub

 

[JHA]

Bonjour à tous,

Désolé, je ne peux pas t'aider en code VBA, patience, il y a des tas de connaisseurs qui vont se pencher sur ta problématique.

Edit: Bonjour @mapomme, @Staple1600, @job75, désolé pour le terme employé "tas", à l'avenir je changerai de mot pour ne pas vous offenser.
Vos réponses correspondent, comme d'habitude, à l'attente de notre ami "steve74".
Pour ma part, je comprends vos codes mais je suis incapable de les construire, on ne se refait pas.

JHA

 

[mapomme]

Bonjour @steve74, @JHA ,

patience, il y a des tas de connaisseurs qui vont se pencher sur ta problématique.

Je fais sans doute partie du tas .

Un essai dans le fichier joint.


edit : v1a avec correction pour les nombres à virgule

Le code dans le module associé à la feuille "Feuil1" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim colon As Range, x As Range, formul$
 
   Set colon = Intersect(Range("a2:a" & Rows.Count), Target)
   If colon Is Nothing Then Exit Sub
   On Error Resume Next
   For Each x In colon
      If x <> "" Then
         If Not x.HasFormula Then
            If IsNumeric(x) Then
               formul = "=" & x.Value & " + " & "$a$1"
               formul = Replace(formul, ",", ".")
               Application.EnableEvents = False: x.Formula = formul: Application.EnableEvents = True
            End If
         End If
      End If
   Next x
End Sub

 

[Staple1600]

Bonjour le fil, steve24, JHA, mapomme

Quand je lis "lors de la saisie", je me dis que ceci devrait suffire

Private Sub Worksheet_Change(ByVal T As Range)
If Not Intersect(Range("A2:A" & Rows.Count), T) Is Nothing Then
Application.EnableEvents = False
If Len(T) Then
T = T + Cells(1)
Application.EnableEvents = True
End If
End If
End Sub

Quand je lis "J'utilise des appareils qui me renvoient la valeur automatiquement"
Alors je me penche sur mapomme et son Edit (non point de Nantes)


Quand je lis "Pour des raisons de confidentialité je ne peux pas soumettre de fichier"
Je pense calembredaines et billevesées
Car dans Excel, on peut toujours faire=> CTRL+N
puis en A2 =ALEA() et recopie jusqu'en A50
Bref, on ne joint jamais le fichier original, on en façonne ex nihilo (usuellement cela incombe au demandeur) pour illustrer la problématique.
Ainsi ne parlait pas Zarathoustra qui ne connaissait pas Bill et son tableur

NB: On notera la présence d'emoticons qui indique clairement que ce message est rédigé en mode "humoristico-informatif"
A moins qu'il ne soit de style informatico-humoristique.

 

[steve74]

Bonjour
oui en effet voici donc un bout de fichier et un grand merci pour l'aide (je suis plus que novice mais j'essaie de comprendre !!!)
Cela marche parfaitement et de plus si la cellule est vide l'opération ne se fait pas (c'est ce que je désirai)

Par contre en cas de retouche du contenu si la personne ne saisie pas de valeur numérique cela arrête la macro (création bug) et après cela ne fonctionne plus.
Comment y remédier ?
Merci pour l'aide

 

[Staple1600]

Re

Une petite modif
(mais reste du peaufinement à faire)

Private Sub Worksheet_Change(ByVal T As Range)
If Not Intersect(Range("A2:A" & Rows.Count), T) Is Nothing Then
If Len(T) Then
If Not IsNumeric(T) Then Exit Sub
Application.EnableEvents = False
T = T + Cells(1)
Application.EnableEvents = True
End If
End If
End Sub

 

[Staple1600]

Re

Petits ajouts
(Mais il y aura sans doute des effets de bord)

Private Sub Worksheet_Change(ByVal T As Range)
If Not Intersect(Range("A2:A" & Rows.Count), T) Is Nothing Then
If Len(T) Then
If Not IsNumeric(T) Then: MsgBox "Erreur!", 16: T = "": Exit Sub
If T.HasFormula Then: MsgBox "Erreur!", 16: T = "": Exit Sub
Application.EnableEvents = False
T = T + Cells(1)
Application.EnableEvents = True
End If
End If
End Sub

 

[mapomme]

Bonsoir,

Tu n'es pas le seul @Staple1600. Moi aussi, je suis transparent de temps à autre...

 

[Staple1600]

Bonsoir mapomme

Bonsoir,

Tu n'es pas le seul @Staple1600. Moi aussi, je suis transparent de temps à autre...

Que nenni
Je vous ai vu
Je me suis même penché sur vous
J'ai fait de l'humour avec vous
cf message#7

Mais il est vrai que je ne suis pas le demandeur

 

[mapomme]

Je me suis même penché sur vous
J'ai fait de l'humour avec vous

Ça j'avais vu

 

[job75]

Bonsoir steve74, JHA, mapomme, JM,

J'ai testé la macro du post #6 de mapomme en entrant la valeur 9 sur la plage A2:A65000.

Chez moi elle s'exécute en 46 secondes.

Pour aller vite il faut utiliser des tableaux VBA sur les zones (Areas) modifiées :

Private Sub Worksheet_Change(ByVal R As Range)
Dim tablo, i&, x$
Set R = Intersect(Range("A2:A" & Rows.Count), R, UsedRange)
Application.EnableEvents = False
[A1] = Val(Replace(CStr([A1]), ",", "."))
If Not R Is Nothing Then
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    For Each R In R.Areas 'si entrées ou effacements mutiples (copier-coller)
        tablo = R.Resize(, 2).Formula 'matrice, plus rapide, au moins 2 éléments
        For i = 1 To UBound(tablo)
            x = CStr(tablo(i, 1))
            If IsNumeric(x) Then tablo(i, 1) = "=" & x & "+A$1"
        Next i
        R = tablo 'restitution
    Next R
End If
Application.EnableEvents = True
End Sub

Avec le même test cette macro s'exécute en 0,23 seconde.

A+

 

[job75]

Ah oui j'ai oublié de traiter les valeurs décimales, utilisez ce fichier (2) :

Private Sub Worksheet_Change(ByVal R As Range)
Dim ds$, tablo, i&, x$
ds = Application.DecimalSeparator
Set R = Intersect(Range("A2:A" & Rows.Count), R, UsedRange)
Application.EnableEvents = False
[A1] = Val(Replace(CStr([A1]), ",", "."))
If Not R Is Nothing Then
    If FilterMode Then ShowAllData 'si la feuille est filtrée
    For Each R In R.Areas 'si entrées ou effacements mutiples (copier-coller)
        tablo = R.Resize(, 2).Formula 'matrice, plus rapide, au moins 2 éléments
        For i = 1 To UBound(tablo)
            x = CStr(tablo(i, 1))
            If IsNumeric(Replace(x, ".", ds)) Then tablo(i, 1) = "=" & x & "+A$1"
        Next i
        R = tablo 'restitution
    Next R
End If
Application.EnableEvents = True
End Sub