XL 2016 Conversion en devise

[marie58]

Bonjour,
J'ai un tableau de reporting que je remplis en monnaie étrangère. Je dois présenter ce tableau en EUR. J'aimerai pouvoir cliquer sur un bouton et qu'une macro s'exécute afin d'avoir ce même tableau en EUR. Ce tableau me sert de base pour des graphiques et des tableaux d'indicateurs. C'est pour cette raison que j'aimerai que ce soit le même document.
Malheureusement je n'ai pas suffisamment de connaissance en vba pour faire cette manipulation. J'espère que quelqu'un pourra m'aider.
Merci d'avance

 

[sylvanu]

Mais le résultat des courses ?
Est ce que ça correspond à ce que vous attendez ?

 

[marie58]

Re,

Une autre approche hyper-rapide. Tout comme ma 1ère proposition, j'ai supposé que les plages à convertir sont fixes.

Oui merci et c'est très rapide effectivement
Je regarde demain en détail

 

[laurent950]

Bonsoir @cp4 , @sylvanu

Votre code est bien @cp4
J'ai changé les plages en fixe et plage variable.

ici :
If Not c.HasFormula = True And c.Value <> Empty Then
si la cellule contient une formule cela n'a aucune action sur cette cellule
si les cellules sont vide alors rien a faire
Il y a des erreurs de formules dans ce tableau donc pour évité de modifié les cellules et les bug
sur ces cellules j'ai utilisé cela
On Error Resume Next

Option Explicit
Dim t As Double
Sub Euro()
    t = Timer
    If ActiveSheet.Range("E1") = "EURO" Then Exit Sub
    EuroRon "EURO"
End Sub
Sub Ron()
    t = Timer
    If ActiveSheet.Range("E1") = "RON" Then Exit Sub
    EuroRon "RON"
End Sub
Private Sub EuroRon(ByRef Monnaie As String)
Dim f As Worksheet
    Set f = Worksheets(ActiveSheet.Name)
Dim Devise As Double
    Range("E1") = Monnaie
Dim r, c As Range
    Set r = f.Range(f.Cells(6, 4), f.Cells(f.Cells(65536, 2).End(xlUp).Row, 16))
    On Error Resume Next
    For Each c In r
        If Not c.HasFormula = True And c.Value <> Empty Then
            c.Value = IIf(f.Range("E1").Value = "EURO", c.Value / 5, c.Value * 5)
        End If
    Next c
    On Error GoTo 0
    MsgBox Int((Timer - t) * 1000) & " ms"
End Sub

 

[marie58]

Mais le résultat des courses ?
Est ce que ça correspond à ce que vous attendez ?

Bonjour,
Oui cela correspond à ce que je voulais.
Merci encore

 

[cp4]

Bonsoir @cp4 , @sylvanu

Votre code est bien @cp4
J'ai changé les plages en fixe et plage variable.

ici :
If Not c.HasFormula = True And c.Value <> Empty Then
si la cellule contient une formule cela n'a aucune action sur cette cellule
si les cellules sont vide alors rien a faire
Il y a des erreurs de formules dans ce tableau donc pour évité de modifié les cellules et les bug
sur ces cellules j'ai utilisé cela
On Error Resume Next

Option Explicit
Dim t As Double
Sub Euro()
    t = Timer
    If ActiveSheet.Range("E1") = "EURO" Then Exit Sub
    EuroRon "EURO"
End Sub
Sub Ron()
    t = Timer
    If ActiveSheet.Range("E1") = "RON" Then Exit Sub
    EuroRon "RON"
End Sub
Private Sub EuroRon(ByRef Monnaie As String)
Dim f As Worksheet
    Set f = Worksheets(ActiveSheet.Name)
Dim Devise As Double
    Range("E1") = Monnaie
Dim r, c As Range
    Set r = f.Range(f.Cells(6, 4), f.Cells(f.Cells(65536, 2).End(xlUp).Row, 16))
    On Error Resume Next
    For Each c In r
        If Not c.HasFormula = True And c.Value <> Empty Then
            c.Value = IIf(f.Range("E1").Value = "EURO", c.Value / 5, c.Value * 5)
        End If
    Next c
    On Error GoTo 0
    MsgBox Int((Timer - t) * 1000) & " ms"
End Sub

Bonjour,

@laurent950 😉: J'adore ton code cependant, tu as mis en dur dans le code "le taux de conversion". Sachant que les taux de change sont très fluctuants. Avec ton code tel quel la conversion sera fausse. Mais j'ai constaté que tu as défini la variable Devise que tu n'as pas utilisé. J'ai donc complété ton code.

Private Sub EuroRon(ByRef Monnaie As String)
    Dim f As Worksheet
    Set f = Worksheets(ActiveSheet.Name)
    Dim Devise As Double
    Range("E1") = Monnaie
    Devise = Range("J2").Value
    Dim r, c As Range
    Set r = f.Range(f.Cells(6, 4), f.Cells(f.Cells(65536, 2).End(xlUp).Row, 16))
    On Error Resume Next
    For Each c In r
        If Not c.HasFormula = True And c.Value <> Empty Then
            [S]'c.Value = IIf(f.Range("E1").Value = "EURO", c.Value / Devise, c.Value * Devise)[/S]
           c.Value = IIf(f.Range("E1").Value = "EURO", c.Value * Devise, c.Value / Devise)
        End If
    Next c
    On Error GoTo 0
    MsgBox Int((Timer - t) * 1000) & " ms"
End Sub

à la prochaine fidèle compagnon Xldien😉

Bonne journée.