Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

steve74

XLDnaute Nouveau
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
 

steve74

XLDnaute Nouveau
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

XLDnaute Nouveau
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

XLDnaute Barbatruc
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
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
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" :
VB:
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
 

Pièces jointes

  • steve74- Ajout constante- v1a.xlsm
    16.6 KB · Affichages: 5
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonjour le fil, steve24, JHA, mapomme

Quand je lis "lors de la saisie", je me dis que ceci devrait suffire
VB:
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

XLDnaute Nouveau
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
 

Pièces jointes

  • test addition vba.xls
    17 KB · Affichages: 5

Staple1600

XLDnaute Barbatruc
Re

Une petite modif
(mais reste du peaufinement à faire)
VB:
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

XLDnaute Barbatruc
Re

Petits ajouts
(Mais il y aura sans doute des effets de bord)
VB:
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
 

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • test addition vba(1).xls
    46.5 KB · Affichages: 3

job75

XLDnaute Barbatruc
Ah oui j'ai oublié de traiter les valeurs décimales, utilisez ce fichier (2) :
VB:
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
 

Pièces jointes

  • test addition vba(2).xls
    46.5 KB · Affichages: 7

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…