XL 2016 Multiplication de plusieurs cellules au clic sur un bouton

Fahim3u

XLDnaute Nouveau
Multiplication de plusieurs cellules au clic sur un bouton
Salut les gars j'ai un petit problème sur excel . Je voudrais appliquer une formule a des cellules dans mon classeur. Le principe c'est de multiplier toutes les valeurs des cellules *24 une fois que je clique sur un bouton. Pouvez vous maider Merci d'avance Merci .
 

Pièces jointes

  • 0_test.xlsx
    10 KB · Affichages: 3

Fahim3u

XLDnaute Nouveau
Salut chalet en faite moi je voudrais que la modification des valeurs lors de la multiplication ca se fait dans le meme tableau . Et normalement les valeurs sont en format heure jai deja fait un macro pour convertir les valeur en nombre et ce que je veux mtn c de multiplier les valeurs en nombre * 24 sur le mm tableau en appuyant sur le bouton . Lobjectif c de faire les modification sur le mm tableau et ne pas faire un autre.
 

job75

XLDnaute Barbatruc
Bonjour Fahim3u, CHALET53,

Voyez le fichier joint et ces macros :
VB:
Sub X_24()
Application.ScreenUpdating = False
[A1] = 24
[A1].Copy
[A7:C9].PasteSpecial xlPasteValues, Operation:=xlMultiply 'plage à adapter
[A1] = ""
[A1].Select
Application.CutCopyMode = 0
End Sub

Sub DIV_24()
Application.ScreenUpdating = False
[A1] = 24
[A1].Copy
[A7:C9].PasteSpecial xlPasteValues, Operation:=xlDivide 'plage à adapter
[A1] = ""
[A1].Select
Application.CutCopyMode = 0
End Sub
A+
 

Pièces jointes

  • 0_test(1).xlsm
    20.9 KB · Affichages: 5

job75

XLDnaute Barbatruc
Une solution par tableaux VBA dans ce fichier(2) :
VB:
Sub X_24()
Dim P As Range, tablo, ncol%, i&, j%, x$
Set P = [A7:C9] 'à adapter
tablo = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
ncol = UBound(tablo, 2)
For i = 1 To UBound(tablo) - 1
    For j = 1 To ncol
        x = CStr(tablo(i, j))
        If IsNumeric(x) Then tablo(i, j) = x * 24
Next j, i
P = tablo
End Sub

Sub DIV_24()
Dim P As Range, tablo, ncol%, i&, j%, x$
Set P = [A7:C9] 'à adapter
tablo = P.Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
ncol = UBound(tablo, 2)
For i = 1 To UBound(tablo) - 1
    For j = 1 To ncol
        x = CStr(tablo(i, j))
        If IsNumeric(x) Then tablo(i, j) = x / 24
Next j, i
P = tablo
End Sub
Pour tester j'ai recopié le tableau A7:C9 sur 120 000 lignes :

- fichier (1) => 0,24 seconde

- fichier (2) => 1,4 seconde, 6 fois moins rapide.

A+
 

Pièces jointes

  • 0_test(2).xlsm
    21.9 KB · Affichages: 6

Staple1600

XLDnaute Barbatruc
Bonjour le fil, Fahim3u, Chalet53, job75

Une version paramétrée (pour avoir les 4 opérations à dispostion et utiliser les possibilités offertes par Intellisense dans VBE)
VB:
 Sub test1()
PasteSpOP xlPasteSpecialOperationDivide
End Sub
Sub test2()
PasteSpOP xlPasteSpecialOperationMultiply, 2
End Sub

Sub test2b()
PasteSpOP 4, 2
End Sub
Private Sub PasteSpOP(op As XlPasteSpecialOperation, Optional oper As Double = 24)
Cells(Rows.Count, Columns.Count) = oper
Cells(Rows.Count, Columns.Count).Copy
Set r = Selection
r.PasteSpecial xlPasteValues, Operation:=op
End Sub
Pour tester, mettre quelques nombres dans un colonne puis sélectionner les données dans cette colonne et lancer les macros selon le besoin.
(Voir les exemples test)
PS: proposition émise pour le fun et pour varier les plaisirs dans VBE. ;)
 

job75

XLDnaute Barbatruc
Bonjour JM,

Plutôt que des boutons on peut utiliser une liste de validation, fichier (3) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Choix]) Is Nothing And [Choix] <> "" Then Macro
End Sub

Sub Macro()
Application.ScreenUpdating = False
[A1] = 24
[A1].Copy
[A7:C9].PasteSpecial xlPasteValues, Operation:=IIf([Choix] = "X 24", xlMultiply, xlDivide) 'plage à adapter
[A1] = ""
[Choix].Select
Application.CutCopyMode = 0
End Sub
A+
 

Pièces jointes

  • 0_test(3).xlsm
    22.6 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonsoir à tous,
j'aimerais bien ne pas avoir la valeur zero 0 lorsque j'appuie sur le bouton
Il suffit de remplir provisoirement les cellules vides avec le texte "µ" :
VB:
Sub X_24()
Application.ScreenUpdating = False
[A1] = 24
With [A7:C9] 'plage à adapter
    .Replace "", "µ", xlWhole 'remplace les vides par µ
    [A1].Copy
    .PasteSpecial xlPasteValues, Operation:=xlMultiply
    .Replace "µ", "" 'efface les µ
End With
[A1] = ""
[A1].Select
Application.CutCopyMode = 0
End Sub

Sub DIV_24()
Application.ScreenUpdating = False
[A1] = 24
With [A7:C9] 'plage à adapter
    .Replace "", "µ", xlWhole 'remplace les vides par µ
    [A1].Copy
    .PasteSpecial xlPasteValues, Operation:=xlDivide
    .Replace "µ", "" 'efface les µ
End With
[A1] = ""
[A1].Select
Application.CutCopyMode = 0
End Sub
Voyez ces fichiers (1 bis) et (3 bis) avec la cellule vide B8.

A+
 

Pièces jointes

  • 0_test(1 bis).xlsm
    21.4 KB · Affichages: 4
  • 0_test(3 bis).xlsm
    23.1 KB · Affichages: 3

Discussions similaires