Je voudrais qu'en cliquant sur une valeur dans une cellule, apparaisse en commentaire la valeur
correspondante en euros.
A mettre dans le module de la feuille :
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
ActiveSheet.UsedRange.ClearComments
If IsNumeric(Target) And Target.Value <> "" Then
Target.AddComment.Text Text:=Round(Target.Value / 6.55957, 2) & " €"
End If
End Sub
Attention, ce code efface tous les commentaires préexistants...
Pour voir la correspondance en francs de valeurs en euros :
Target.AddComment.Text Text:=Round(Target.Value * 6.55957, 2) & " FF"
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
ActiveSheet.UsedRange.ClearComments
If IsNumeric(Target) And Target.Value <> "" Then
Target.AddComment.Text Text:=Round(Target.Value / 6.55957, 2) & " €"
End If
End Sub
Attention, ce code efface tous les commentaires préexistants...
Pour voir la correspondance en francs de valeurs en euros :
Target.AddComment.Text Text:=Round(Target.Value * 6.55957, 2) & " FF"
Jacques Chaussard, Flo Cabon, (N°655)
Je voudrais faire apparaitre la valeur en euros dans la zone de commentaire quand je clique sur
la cellule.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
ActiveSheet.UsedRange.ClearComments
If IsNumeric(Target) And Target.Value <> "" Then
Target.AddComment.Text Text:="Euro :" & Chr(10) & Target.Value / 6.55957 & "Euros "
End If
End Sub
attention, ne pas utiliser cette macro dans des feuilles contenant des
commentaires (on pourrait faire une boucle sur chacun des commentaires pour
reconnaître ceux qui commencent par Euro, mais ça deviendrait très lent)
La macro (recopiée dans la feuille de code de la page de calcul concernée)
affiche en commentaire la valeur en Euro dès qu'on sélectionne une cellule
ActiveSheet.UsedRange.ClearComments
If IsNumeric(Target) And Target.Value <> "" Then
Target.AddComment.Text Text:="Euro :" & Chr(10) & Target.Value / 6.55957 & "Euros "
End If
End Sub
attention, ne pas utiliser cette macro dans des feuilles contenant des
commentaires (on pourrait faire une boucle sur chacun des commentaires pour
reconnaître ceux qui commencent par Euro, mais ça deviendrait très lent)
La macro (recopiée dans la feuille de code de la page de calcul concernée)
affiche en commentaire la valeur en Euro dès qu'on sélectionne une cellule
Jacques Chaussard, (N°654)
Traitement des différents cas
Sub euro()
For Each c In Selection
MyVar = c
'Test de la cellule
MyCheck = IsNumeric(MyVar) 'Si c'est pas un chiffre,
If MyCheck = False Then GoTo suivant 'alors on passe directement à la cellule suivante
If c.HasFormula Then
GoTo suite 'Si la cellule contient une formule alors on passe à la suite (mise en forme)
'sans toucher à la formule
If c.NumberFormat = "#,##0.00 €"
Then GoTo suite 'Si la cellule est déjà en Euro,
' plus besoin de convertir
c.Value = c / 40.3399
'Convertion : ici FB en Euro
suite:
c.NumberFormat = "#,##0.00 €"
suivant:
Next c
End Sub
J'ai choisi de faire la convertion dans une zone
sélectionnée, pour gagner du temps.
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de
J@C, FS, Daniel F, Benoit et Papou.
Cette astuce est illustrée dans ce classeur exemple :
essaiseuro (téléchargé 2901 fois)
For Each c In Selection
MyVar = c
'Test de la cellule
MyCheck = IsNumeric(MyVar) 'Si c'est pas un chiffre,
If MyCheck = False Then GoTo suivant 'alors on passe directement à la cellule suivante
If c.HasFormula Then
GoTo suite 'Si la cellule contient une formule alors on passe à la suite (mise en forme)
'sans toucher à la formule
If c.NumberFormat = "#,##0.00 €"
Then GoTo suite 'Si la cellule est déjà en Euro,
' plus besoin de convertir
c.Value = c / 40.3399
'Convertion : ici FB en Euro
suite:
c.NumberFormat = "#,##0.00 €"
suivant:
Next c
End Sub
J'ai choisi de faire la convertion dans une zone
sélectionnée, pour gagner du temps.
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de
J@C, FS, Daniel F, Benoit et Papou.
Cette astuce est illustrée dans ce classeur exemple :essaiseuro (téléchargé 2901 fois)
Benoit, (N°653)
Conversion dans les cellules sélectionnées
Un peu plus rapide que les macros basées sur des boucles For Each... Next...
Pour utiliser la macro, après avoir sélectionné la plage de valeurs
numériques à convertir, on lance la macro ad hoc qui convertit (important)
dans les cellules sélectionnées elles-mêmes et non dans des cellules
adjacentes.
Cette macro permet les sélections multiples, détecte les formules mais ne permet pas de
les conserver.
Sub FrancEnEuro()
Euro = 6.55957
Dim Derlign As Long
Dim Dercol As Integer
Dim Premlign As Long
Dim Premcol As Integer
Dim Tabl
Dim Cellule
Dim I As Long, J As Integer
Dim SelZones() As Range
Dim NumZones As Integer, z As Integer
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
On Error GoTo fin
' Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
' Nomme la plage à convertir
ActiveWorkbook.Names.Add Name:="plageconversion",
RefersToR1C1:=Selection
' Stocke les différentes zones de la plage sélectionnée
NumZones = Selection.Areas.Count
ReDim SelZones(1 To NumZones)
For z = 1 To NumZones
Set SelZones(z) = Selection.Areas(z)
Next
' teste la plage pour vérifier si elle contient des formules
For z = 1 To NumZones
With Selection
Set c = .Find("=*", LookIn:=xlFormulas)
If Not c Is Nothing Then
GoTo Alerteformule
End If
End With
Next z
GoTo conversion
' message de choix si c'est le cas (on peut remplacer par une sortie Goto
fin si on veut interdire la conversion des formules)
Alerteformule:
Msg = "Cette sélection contient des formules de calculs. Celles-ci
seront converties en valeurs et définitivement perdues. Souhaitez-vous
continuer ?"
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Définit les boutons.
Title = "Conversion des formules ???" ' Définit le titre.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' Lutilisateur a choisit Yes.
GoTo conversion ' Effectue une action.
Else ' L'utilisateur a choisi No.
GoTo fin ' annulation de la conversion.
End If
' Conversion des données numériques
conversion:
For z = 1 To NumZones
SelZones(z).Select
Tabl = Selection.Value
Derlign = Selection.Rows(Selection.Rows.Count).Row
Premlign = Selection.Row
Premcol = Selection.Column
Dercol = Selection.Columns(Selection.Columns.Count).Column
If Premlign = Derlign And Premcol = Dercol Then
GoTo pourcellule
End If
For I = 1 To (Derlign - Premlign + 1)
For J = 1 To (Dercol - Premcol + 1)
Tabl(I, J) = Application.Round((Tabl(I, J) / Euro), 2)
Next J
Next I
Application.ScreenUpdating = False
Selection.Value = Tabl
GoTo formatzone
pourcellule:
Cellule = Selection.Value
Application.ScreenUpdating = False
Cellule = Application.Round((Cellule / Euro), 2)
Selection.Value = Cellule
formatzone:
FormatEuro = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
With Selection
.NumberFormatLocal = FormatEuro
End With
Selection.Columns.AutoFit
Next z
Application.ScreenUpdating = True
Range("plageconversion").Select
Exit Sub
fin:
ActiveWorkbook.Names("plageconversion").Delete
Application.ScreenUpdating = True
End Sub
Sub EuroEnFranc()
Euro = 6.55957
Dim Derlign As Long
Dim Dercol As Integer
Dim Premlign As Long
Dim Premcol As Integer
Dim Tabl
Dim Cellule
Dim I As Long, J As Integer
Dim SelZones() As Range
Dim NumZones As Integer, z As Integer
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
On Error GoTo fin
' Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
' Nomme la plage à convertir
ActiveWorkbook.Names.Add Name:="plageconversion",
RefersToR1C1:=Selection
' Stocke les différentes zones de la plage sélectionnée
NumZones = Selection.Areas.Count
ReDim SelZones(1 To NumZones)
For z = 1 To NumZones
Set SelZones(z) = Selection.Areas(z)
Next
' teste la plage pour vérifier si elle contient des formules
For z = 1 To NumZones
With Selection
Set c = .Find("=*", LookIn:=xlFormulas)
If Not c Is Nothing Then
GoTo Alerteformule
End If
End With
Next z
GoTo conversion
' message de choix si c'est le cas (on peut remplacer par une sortie Goto
fin si on veut interdire la conversion des formules)
Alerteformule:
Msg = "Cette sélection contient des formules de calculs. Celles-ci
seront converties en valeurs et définitivement perdues. Souhaitez-vous
continuer ?"
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Définit les boutons.
Title = "Conversion des formules ???" ' Définit le titre.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' Lutilisateur a choisit Yes.
GoTo conversion ' Effectue une action.
Else ' Lutilisateur a choisi No.
GoTo fin ' annulation de la conversion.
End If
' Conversion des données numériques
conversion:
For z = 1 To NumZones
SelZones(z).Select
Tabl = Selection.Value
Derlign = Selection.Rows(Selection.Rows.Count).Row
Premlign = Selection.Row
Premcol = Selection.Column
Dercol = Selection.Columns(Selection.Columns.Count).Column
If Premlign = Derlign And Premcol = Dercol Then
GoTo pourcellule
End If
For I = 1 To (Derlign - Premlign + 1)
For J = 1 To (Dercol - Premcol + 1)
Tabl(I, J) = Application.Round((Tabl(I, J) * Euro), 2)
Next J
Next I
Application.ScreenUpdating = False
Application.ScreenUpdating = False
Selection.Value = Tabl
GoTo formatzone
pourcellule:
Cellule = Selection.Value
Application.ScreenUpdating = False
Cellule = Application.Round((Cellule * Euro), 2)
Selection.Value = Cellule
formatzone:
FormatFranc = _
"_-* # ##0,00\ [$F-1]_-;-* # ##0,00\ [$F-1]_-;_-* ""-""??\ [$F-1]_-;_-@_-"
With Selection
.NumberFormatLocal = FormatFranc
End With
Selection.Columns.AutoFit
Next z
Application.ScreenUpdating = True
Range("plageconversion").Select
Exit Sub
fin:
ActiveWorkbook.Names("plageconversion").Delete
Application.ScreenUpdating = True
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou.
Pour utiliser la macro, après avoir sélectionné la plage de valeurs
numériques à convertir, on lance la macro ad hoc qui convertit (important)
dans les cellules sélectionnées elles-mêmes et non dans des cellules
adjacentes.
Cette macro permet les sélections multiples, détecte les formules mais ne permet pas de
les conserver.
Sub FrancEnEuro()
Euro = 6.55957
Dim Derlign As Long
Dim Dercol As Integer
Dim Premlign As Long
Dim Premcol As Integer
Dim Tabl
Dim Cellule
Dim I As Long, J As Integer
Dim SelZones() As Range
Dim NumZones As Integer, z As Integer
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
On Error GoTo fin
' Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
' Nomme la plage à convertir
ActiveWorkbook.Names.Add Name:="plageconversion",
RefersToR1C1:=Selection
' Stocke les différentes zones de la plage sélectionnée
NumZones = Selection.Areas.Count
ReDim SelZones(1 To NumZones)
For z = 1 To NumZones
Set SelZones(z) = Selection.Areas(z)
Next
' teste la plage pour vérifier si elle contient des formules
For z = 1 To NumZones
With Selection
Set c = .Find("=*", LookIn:=xlFormulas)
If Not c Is Nothing Then
GoTo Alerteformule
End If
End With
Next z
GoTo conversion
' message de choix si c'est le cas (on peut remplacer par une sortie Goto
fin si on veut interdire la conversion des formules)
Alerteformule:
Msg = "Cette sélection contient des formules de calculs. Celles-ci
seront converties en valeurs et définitivement perdues. Souhaitez-vous
continuer ?"
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Définit les boutons.
Title = "Conversion des formules ???" ' Définit le titre.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' Lutilisateur a choisit Yes.
GoTo conversion ' Effectue une action.
Else ' L'utilisateur a choisi No.
GoTo fin ' annulation de la conversion.
End If
' Conversion des données numériques
conversion:
For z = 1 To NumZones
SelZones(z).Select
Tabl = Selection.Value
Derlign = Selection.Rows(Selection.Rows.Count).Row
Premlign = Selection.Row
Premcol = Selection.Column
Dercol = Selection.Columns(Selection.Columns.Count).Column
If Premlign = Derlign And Premcol = Dercol Then
GoTo pourcellule
End If
For I = 1 To (Derlign - Premlign + 1)
For J = 1 To (Dercol - Premcol + 1)
Tabl(I, J) = Application.Round((Tabl(I, J) / Euro), 2)
Next J
Next I
Application.ScreenUpdating = False
Selection.Value = Tabl
GoTo formatzone
pourcellule:
Cellule = Selection.Value
Application.ScreenUpdating = False
Cellule = Application.Round((Cellule / Euro), 2)
Selection.Value = Cellule
formatzone:
FormatEuro = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
With Selection
.NumberFormatLocal = FormatEuro
End With
Selection.Columns.AutoFit
Next z
Application.ScreenUpdating = True
Range("plageconversion").Select
Exit Sub
fin:
ActiveWorkbook.Names("plageconversion").Delete
Application.ScreenUpdating = True
End Sub
Sub EuroEnFranc()
Euro = 6.55957
Dim Derlign As Long
Dim Dercol As Integer
Dim Premlign As Long
Dim Premcol As Integer
Dim Tabl
Dim Cellule
Dim I As Long, J As Integer
Dim SelZones() As Range
Dim NumZones As Integer, z As Integer
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
On Error GoTo fin
' Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
' Nomme la plage à convertir
ActiveWorkbook.Names.Add Name:="plageconversion",
RefersToR1C1:=Selection
' Stocke les différentes zones de la plage sélectionnée
NumZones = Selection.Areas.Count
ReDim SelZones(1 To NumZones)
For z = 1 To NumZones
Set SelZones(z) = Selection.Areas(z)
Next
' teste la plage pour vérifier si elle contient des formules
For z = 1 To NumZones
With Selection
Set c = .Find("=*", LookIn:=xlFormulas)
If Not c Is Nothing Then
GoTo Alerteformule
End If
End With
Next z
GoTo conversion
' message de choix si c'est le cas (on peut remplacer par une sortie Goto
fin si on veut interdire la conversion des formules)
Alerteformule:
Msg = "Cette sélection contient des formules de calculs. Celles-ci
seront converties en valeurs et définitivement perdues. Souhaitez-vous
continuer ?"
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Définit les boutons.
Title = "Conversion des formules ???" ' Définit le titre.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' Lutilisateur a choisit Yes.
GoTo conversion ' Effectue une action.
Else ' Lutilisateur a choisi No.
GoTo fin ' annulation de la conversion.
End If
' Conversion des données numériques
conversion:
For z = 1 To NumZones
SelZones(z).Select
Tabl = Selection.Value
Derlign = Selection.Rows(Selection.Rows.Count).Row
Premlign = Selection.Row
Premcol = Selection.Column
Dercol = Selection.Columns(Selection.Columns.Count).Column
If Premlign = Derlign And Premcol = Dercol Then
GoTo pourcellule
End If
For I = 1 To (Derlign - Premlign + 1)
For J = 1 To (Dercol - Premcol + 1)
Tabl(I, J) = Application.Round((Tabl(I, J) * Euro), 2)
Next J
Next I
Application.ScreenUpdating = False
Application.ScreenUpdating = False
Selection.Value = Tabl
GoTo formatzone
pourcellule:
Cellule = Selection.Value
Application.ScreenUpdating = False
Cellule = Application.Round((Cellule * Euro), 2)
Selection.Value = Cellule
formatzone:
FormatFranc = _
"_-* # ##0,00\ [$F-1]_-;-* # ##0,00\ [$F-1]_-;_-* ""-""??\ [$F-1]_-;_-@_-"
With Selection
.NumberFormatLocal = FormatFranc
End With
Selection.Columns.AutoFit
Next z
Application.ScreenUpdating = True
Range("plageconversion").Select
Exit Sub
fin:
ActiveWorkbook.Names("plageconversion").Delete
Application.ScreenUpdating = True
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou.
Daniel Fieux, (N°652)
EuroXL
anonyme, (N°651)
Qu'est ce que ce euroconvert.xla qui apparait dans VBE ? Comment la désactiver ?
C'est une macro complémentaire de excel.
EUROCONVERT(A1;""FRF"";""EUR"")
convertit les francs en euro ; si tu mets ""DEM"" à la place
d'""EUR"", la conversion est en deutsche mark, etc... pour les pays
adoptant l'euro.
Pour la désactiver, dans le menu outils/macros complémentaires, décoche la case correspondante.
Elle produit parfois des erreurs au démarrage :-( Et puis de toutes façons, on y est à l'euro !
EUROCONVERT(A1;""FRF"";""EUR"")
convertit les francs en euro ; si tu mets ""DEM"" à la place
d'""EUR"", la conversion est en deutsche mark, etc... pour les pays
adoptant l'euro.
Pour la désactiver, dans le menu outils/macros complémentaires, décoche la case correspondante.
Elle produit parfois des erreurs au démarrage :-( Et puis de toutes façons, on y est à l'euro !
Flo Cabon, (N°650)
Une macro à télécharger ?
David Aubert, (N°649)
Conversion Francs-Euros de plages de cellules qui peuvent contenir des constantes et des
formules.
Function HasPrecedents(cell As Range)
'Teste si une cellule qui contient une formule dépend ou non d'autres cellules
'pour son résultat. Si oui, ces cellules contiennent sans doute des constantes
'convertibles (donc inutile de re-convertir). Si non, la cellule testée contient
'sans doute des constantes ou une formule locale (donc à convertir)
Dim test As Range
On Error Resume Next
Set test = cell.Precedents
HasPrecedents = Err = 0
Err.Clear
End Function
Sub FormulesFrancsEuros()
Dim Formule$, cell As Range, valeur As Variant
Const FormatEuro As String = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
Const FormatFranc As String = _
'"_-* # ##0,00 F_-;-* # ##0,00 F_-;_-* ""-""?? F_-;_-@_-"
For Each cell In Selection
If Not cell.NumberFormatLocal = FormatFranc Then GoTo Suite
If HasPrecedents(cell) Then
cell.NumberFormatLocal = FormatEuro
GoTo Suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/6.55957,2)"
Else
valeur = Round(cell.Value / 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormatLocal = FormatEuro
End If
Suite:
Next cell
End Sub
Sub FormulesFrancsBelgesEuros()
Dim Formule$, cell As Range, valeur As Variant
Const FormatEuro As String = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
For Each cell In Selection
If HasPrecedents(cell) Then
cell.NumberFormatLocal = FormatEuro
GoTo Suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/40.3399,2)"
Else
valeur = Round(cell.Value / 40.3399, 2)
cell.Value = valeur
End If
cell.NumberFormatLocal = FormatEuro
End If
Suite:
Next cell
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou.
'Teste si une cellule qui contient une formule dépend ou non d'autres cellules
'pour son résultat. Si oui, ces cellules contiennent sans doute des constantes
'convertibles (donc inutile de re-convertir). Si non, la cellule testée contient
'sans doute des constantes ou une formule locale (donc à convertir)
Dim test As Range
On Error Resume Next
Set test = cell.Precedents
HasPrecedents = Err = 0
Err.Clear
End Function
Sub FormulesFrancsEuros()
Dim Formule$, cell As Range, valeur As Variant
Const FormatEuro As String = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
Const FormatFranc As String = _
'"_-* # ##0,00 F_-;-* # ##0,00 F_-;_-* ""-""?? F_-;_-@_-"
For Each cell In Selection
If Not cell.NumberFormatLocal = FormatFranc Then GoTo Suite
If HasPrecedents(cell) Then
cell.NumberFormatLocal = FormatEuro
GoTo Suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/6.55957,2)"
Else
valeur = Round(cell.Value / 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormatLocal = FormatEuro
End If
Suite:
Next cell
End Sub
Sub FormulesFrancsBelgesEuros()
Dim Formule$, cell As Range, valeur As Variant
Const FormatEuro As String = _
"_-* # ##0,00\ [$€-1]_-;-* # ##0,00\ [$€-1]_-;_-* ""-""??\ [$€-1]_-;_-@_-"
For Each cell In Selection
If HasPrecedents(cell) Then
cell.NumberFormatLocal = FormatEuro
GoTo Suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/40.3399,2)"
Else
valeur = Round(cell.Value / 40.3399, 2)
cell.Value = valeur
End If
cell.NumberFormatLocal = FormatEuro
End If
Suite:
Next cell
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou.
Frédéric Sigonneau, (N°648)
Plus compliqué, pour conserver les valeurs et formules et les diviser par 6.55957
Sub Macreuro2()
ActiveCell.FormulaR1C1 = "=(" & _
WorksheetFunction.Substitute(ActiveCell.FormulaR1C1, "=", "") & ")/6.55957"
End Sub
puis outils=> macros=> macro=> options=> touche de raccourcis : CTRL+E pour affecter ce
raccourci à la macro.
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de
J@C, FS, Daniel F, Benoit et Papou.
ActiveCell.FormulaR1C1 = "=(" & _
WorksheetFunction.Substitute(ActiveCell.FormulaR1C1, "=", "") & ")/6.55957"
End Sub
puis outils=> macros=> macro=> options=> touche de raccourcis : CTRL+E pour affecter ce
raccourci à la macro.
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de
J@C, FS, Daniel F, Benoit et Papou.
Jacques Chaussard, (N°647)
Une macro complémentaire
Ci joint une macro complémentaire pour gérer des euros (une de plus), mais qui possède
les particularités suivantes:
Généralités :
Conversion de francs en euros ou euros en francs, dollars ou livres.
Le taux de conversion en dollars ou livres est modifiable par l'utilisateur.
- Possibilité d'ajouter un symbole monétaire sans appliquer de taux de conversion.
- Appliquer un taux de conversion avec ajout ou non du symbole monétaire correspondant.
Si ajout : Choix entre 2 formats (monétaire ou comptabilité).
Remarques:
Le nombre de décimales après conversion est identique à celui d'origine.
La conversion ne fait pas d'arrondi; la conversion inverse redonne les valeurs d'origine.
L'annulation est possible par le bouton "Undo" de la barre de feuille de calcul.
La conversion est applicable sur toute la feuille ou selon la sélection utilisateur.
Cette astuce est illustrée dans ce classeur exemple :
mp-euroconverter (téléchargé 2846 fois)
les particularités suivantes:
Généralités :
Conversion de francs en euros ou euros en francs, dollars ou livres.
Le taux de conversion en dollars ou livres est modifiable par l'utilisateur.
- Possibilité d'ajouter un symbole monétaire sans appliquer de taux de conversion.
- Appliquer un taux de conversion avec ajout ou non du symbole monétaire correspondant.
Si ajout : Choix entre 2 formats (monétaire ou comptabilité).
Remarques:
Le nombre de décimales après conversion est identique à celui d'origine.
La conversion ne fait pas d'arrondi; la conversion inverse redonne les valeurs d'origine.
L'annulation est possible par le bouton "Undo" de la barre de feuille de calcul.
La conversion est applicable sur toute la feuille ou selon la sélection utilisateur.
Cette astuce est illustrée dans ce classeur exemple :mp-euroconverter (téléchargé 2846 fois)
Michel Pierron, (N°646)
Solution qui gère les différentes situations
Une solution pour la conversion de feuilles en Euro : les macros incluses
effectuent le travail en plusieurs étapes :
1 - repérer les cellules contenant des valeurs, en leur donnant un fond
strié, en excluant donc les formules (qui doivent se recalculer), les dates
et les textes. Ce repérage peut être refait autant de fois que nécessaire.
Procédure "RepererCellules"
2 - modifier (à la mimine) les valeurs A NE PAS MODIFIER en les faisant
précéder du signe "=" pour les faire considérer comme des formules
3 - vérifier encore...
4 - lancer la conversion (Procedure ConvertirTableauEnEuro) : toutes les
valeurs seront divisées par le taux 6.55957 (modifiable dans le programme
pour d'autres monnaies que le franc français) avec une précision dépendant
du format de la cellule (pas de décimales qui traînent et faussent les
calculs).
Cette astuce est illustrée dans ce classeur exemple :
df-euro (téléchargé 2779 fois)
effectuent le travail en plusieurs étapes :
1 - repérer les cellules contenant des valeurs, en leur donnant un fond
strié, en excluant donc les formules (qui doivent se recalculer), les dates
et les textes. Ce repérage peut être refait autant de fois que nécessaire.
Procédure "RepererCellules"
2 - modifier (à la mimine) les valeurs A NE PAS MODIFIER en les faisant
précéder du signe "=" pour les faire considérer comme des formules
3 - vérifier encore...
4 - lancer la conversion (Procedure ConvertirTableauEnEuro) : toutes les
valeurs seront divisées par le taux 6.55957 (modifiable dans le programme
pour d'autres monnaies que le franc français) avec une précision dépendant
du format de la cellule (pas de décimales qui traînent et faussent les
calculs).
Cette astuce est illustrée dans ce classeur exemple :df-euro (téléchargé 2779 fois)
Didier Bicking, (N°645)
Solution de windows news de mai 2001
Vous pouvez pour éviter les erreurs télécharger le classeur
qui contient une Notice d'install, un exemple et les
précautions à prendre au niveau de la conversion :
Le code ci dessous ne montre pas le userform associé.
Public TablEuros(11, 2)
Public vZone, vConversion As Integer
Public vDevise As String
Public vFormat As Boolean
Public vTaux
'*****************************************************
'*** Installation du bouton dans la barre d'outils ***
'*****************************************************
Sub auto_open()
Set vBouton = Application.CommandBars
("Standard").Controls.Add(Type:=msoControlButton, _
ID:=2950, Before:=4, temporary:=True)
vBouton.OnAction = "Euros"
vBouton.Caption = "Conversion en euros"
vBouton.FaceId = 29
End Sub
'*********************************************************
'*** Routine principale exécutée au clic sur le bouton ***
'*********************************************************
Sub Euros()
'*** Initialisation du tableau des devises
TablEuros(0, 0) = "France"
TablEuros(0, 1) = "FRF"
TablEuros(0, 2) = 6.55957
TablEuros(1, 0) = "Belgique"
TablEuros(1, 1) = "BEF"
TablEuros(1, 2) = 40.3399
TablEuros(2, 0) = "Allemagne"
TablEuros(2, 1) = "DEM"
TablEuros(2, 2) = 1.95583
TablEuros(3, 0) = "Grèce"
TablEuros(3, 1) = "GRD"
TablEuros(3, 2) = 340.75
TablEuros(4, 0) = "Espagne"
TablEuros(4, 1) = "ESP"
TablEuros(4, 2) = 166.386
TablEuros(5, 0) = "Irlande"
TablEuros(5, 1) = "IEP"
TablEuros(5, 2) = 0.787564
TablEuros(6, 0) = "Italie"
TablEuros(6, 1) = "ITL"
TablEuros(6, 2) = 1936.27
TablEuros(7, 0) = "Luxembourg"
TablEuros(7, 1) = "LUF"
TablEuros(7, 2) = 40.3399
TablEuros(8, 0) = "Pays-Bas"
TablEuros(8, 1) = "NLG"
TablEuros(8, 2) = 2.20371
TablEuros(9, 0) = "Autriche"
TablEuros(9, 1) = "ATS"
TablEuros(9, 2) = 13.7603
TablEuros(10, 0) = "Portugal"
TablEuros(10, 1) = "PTE"
TablEuros(10, 2) = 200.482
TablEuros(11, 0) = "Finlande"
TablEuros(11, 1) = "FIM"
TablEuros(11, 2) = 5.94573
'*** Chargement en mémoire du formulaire
Load FrmEuros
'*** Initialisation des contrôles dans le formulaire
FrmEuros.CmbDevises.List = TablEuros
FrmEuros.CmbDevises.ListIndex = 0
FrmEuros.TxtMonnaie = TablEuros(0, 1)
FrmEuros.TxtConversion = TablEuros(0, 2)
FrmEuros.ChbCopier = True
FrmEuros.OptFormules = True
FrmEuros.ChbFormat = True
'*** Affichage du formulaire
FrmEuros.Show
End Sub
'*******************************************************
'*** Conversion dans toutes les feuilles du classeur ***
'*******************************************************
Sub EurosClasseur()
Dim vDernièreCellule
For Each Feuille In ActiveWorkbook.Worksheets
'* Activation de la feuille
Feuille.Activate
'* L'adresse de la dernière cellule occupée de la feuille
vDernièreCellule = ActiveCell.SpecialCells(xlLastCell).Address
For Each cell In ActiveSheet.Cells
If cell.Address = vDernièreCellule Then Exit For
If cell.Address = vDernièreCellule Then Exit For
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1,
cell.NumberFormat, "m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat
= "#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
Next
End Sub
'*****************************************
'*** Conversion dans la feuille active ***
'*****************************************
Sub EurosFeuille()
Dim vDernièreCellule
'* L'adresse de la dernière cellule occupée de la feuille
vDernièreCellule = ActiveCell.SpecialCells(xlLastCell).Address
For Each cell In ActiveSheet.Cells
If cell.Address = vDernièreCellule Then Exit For
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1,
cell.NumberFormat, "m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat = "
#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
End Sub
'*********************************************
'*** Conversion dans la plage sélectionnée ***
'*********************************************
Sub EurosPlage()
For Each cell In Selection
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1, cell.NumberFormat,
"m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat = "
#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
End Sub
'**********************************************************************
'*** Fonction appelée par EurosPlage, EurosClasseur et EurosFeuille ***
'**********************************************************************
Function Conversion(Contenu, vDate)
Dim ContenuTemp
ContenuTemp = Contenu
Select Case Left(Contenu, 1)
'* Dans le cas où la cellule contient une formule
Case Is = "="
'* Si Formules a été choisi dans la boîte de dialogue
If vConversion = 1 Then
ContenuTemp = "=Arrondi((" & _
Right(Contenu, Len(Contenu) - 1) & _
")/" & vTaux & ";2)"
End If
'* Dans le cas où la cellule ne contient pas une formule
Case Is <> "="
'* Si Données a été choisi dans la boîte de dialogue et
'* si la cellule n'est pas vide et ne contient pas de texte
'* ni de date
If vConversion = 2 And Val(Contenu) <> 0 And vDate = 0 Then
ContenuTemp = "=Arrondi(" & _
Contenu & "/" & vTaux & ";2)"
End If
End Select
Conversion = ContenuTemp
End Function
qui contient une Notice d'install, un exemple et les
précautions à prendre au niveau de la conversion :
Le code ci dessous ne montre pas le userform associé.
Public TablEuros(11, 2)
Public vZone, vConversion As Integer
Public vDevise As String
Public vFormat As Boolean
Public vTaux
'*****************************************************
'*** Installation du bouton dans la barre d'outils ***
'*****************************************************
Sub auto_open()
Set vBouton = Application.CommandBars
("Standard").Controls.Add(Type:=msoControlButton, _
ID:=2950, Before:=4, temporary:=True)
vBouton.OnAction = "Euros"
vBouton.Caption = "Conversion en euros"
vBouton.FaceId = 29
End Sub
'*********************************************************
'*** Routine principale exécutée au clic sur le bouton ***
'*********************************************************
Sub Euros()
'*** Initialisation du tableau des devises
TablEuros(0, 0) = "France"
TablEuros(0, 1) = "FRF"
TablEuros(0, 2) = 6.55957
TablEuros(1, 0) = "Belgique"
TablEuros(1, 1) = "BEF"
TablEuros(1, 2) = 40.3399
TablEuros(2, 0) = "Allemagne"
TablEuros(2, 1) = "DEM"
TablEuros(2, 2) = 1.95583
TablEuros(3, 0) = "Grèce"
TablEuros(3, 1) = "GRD"
TablEuros(3, 2) = 340.75
TablEuros(4, 0) = "Espagne"
TablEuros(4, 1) = "ESP"
TablEuros(4, 2) = 166.386
TablEuros(5, 0) = "Irlande"
TablEuros(5, 1) = "IEP"
TablEuros(5, 2) = 0.787564
TablEuros(6, 0) = "Italie"
TablEuros(6, 1) = "ITL"
TablEuros(6, 2) = 1936.27
TablEuros(7, 0) = "Luxembourg"
TablEuros(7, 1) = "LUF"
TablEuros(7, 2) = 40.3399
TablEuros(8, 0) = "Pays-Bas"
TablEuros(8, 1) = "NLG"
TablEuros(8, 2) = 2.20371
TablEuros(9, 0) = "Autriche"
TablEuros(9, 1) = "ATS"
TablEuros(9, 2) = 13.7603
TablEuros(10, 0) = "Portugal"
TablEuros(10, 1) = "PTE"
TablEuros(10, 2) = 200.482
TablEuros(11, 0) = "Finlande"
TablEuros(11, 1) = "FIM"
TablEuros(11, 2) = 5.94573
'*** Chargement en mémoire du formulaire
Load FrmEuros
'*** Initialisation des contrôles dans le formulaire
FrmEuros.CmbDevises.List = TablEuros
FrmEuros.CmbDevises.ListIndex = 0
FrmEuros.TxtMonnaie = TablEuros(0, 1)
FrmEuros.TxtConversion = TablEuros(0, 2)
FrmEuros.ChbCopier = True
FrmEuros.OptFormules = True
FrmEuros.ChbFormat = True
'*** Affichage du formulaire
FrmEuros.Show
End Sub
'*******************************************************
'*** Conversion dans toutes les feuilles du classeur ***
'*******************************************************
Sub EurosClasseur()
Dim vDernièreCellule
For Each Feuille In ActiveWorkbook.Worksheets
'* Activation de la feuille
Feuille.Activate
'* L'adresse de la dernière cellule occupée de la feuille
vDernièreCellule = ActiveCell.SpecialCells(xlLastCell).Address
For Each cell In ActiveSheet.Cells
If cell.Address = vDernièreCellule Then Exit For
If cell.Address = vDernièreCellule Then Exit For
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1,
cell.NumberFormat, "m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat
= "#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
Next
End Sub
'*****************************************
'*** Conversion dans la feuille active ***
'*****************************************
Sub EurosFeuille()
Dim vDernièreCellule
'* L'adresse de la dernière cellule occupée de la feuille
vDernièreCellule = ActiveCell.SpecialCells(xlLastCell).Address
For Each cell In ActiveSheet.Cells
If cell.Address = vDernièreCellule Then Exit For
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1,
cell.NumberFormat, "m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat = "
#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
End Sub
'*********************************************
'*** Conversion dans la plage sélectionnée ***
'*********************************************
Sub EurosPlage()
For Each cell In Selection
If InStr(1, cell.NumberFormat, "d") > 0 Or InStr(1, cell.NumberFormat,
"m") > 0 _
Or InStr(1, cell.NumberFormat, "y") > 0 Then
vDate = 1
Else
vDate = 0
End If
cell.FormulaLocal = Conversion(cell.FormulaLocal, vDate)
If vFormat And vConversion = 2 And vDate = 0 Then cell.NumberFormat = "
#,##0.00 €"
If vFormat And vConversion = 1 And vDate = 0 Then
If Left(cell.Formula, 1) = "=" Then
cell.NumberFormat = "#,##0.00 €"
Else
cell.NumberFormat = "#,##0.00 " & vDevise
End If
End If
Next
End Sub
'**********************************************************************
'*** Fonction appelée par EurosPlage, EurosClasseur et EurosFeuille ***
'**********************************************************************
Function Conversion(Contenu, vDate)
Dim ContenuTemp
ContenuTemp = Contenu
Select Case Left(Contenu, 1)
'* Dans le cas où la cellule contient une formule
Case Is = "="
'* Si Formules a été choisi dans la boîte de dialogue
If vConversion = 1 Then
ContenuTemp = "=Arrondi((" & _
Right(Contenu, Len(Contenu) - 1) & _
")/" & vTaux & ";2)"
End If
'* Dans le cas où la cellule ne contient pas une formule
Case Is <> "="
'* Si Données a été choisi dans la boîte de dialogue et
'* si la cellule n'est pas vide et ne contient pas de texte
'* ni de date
If vConversion = 2 And Val(Contenu) <> 0 And vDate = 0 Then
ContenuTemp = "=Arrondi(" & _
Contenu & "/" & vTaux & ";2)"
End If
End Select
Conversion = ContenuTemp
End Function
Windows-News, (N°644)
pour clic droit
Cette solution crée un menu contextuel dans le clic droit qui permet de
convertir à la volée les valeurs de l'euro vers le franc et réciproquement.
Sub euroclicdroit()
Dim NouvelOp As CommandBarControl, option1 As CommandBarControl,
option2 As
CommandBarControl
Set NouvelOp =
CommandBars("Cell").Controls.Add(msoControlPopup, , , , True)
With
NouvelOp
.Caption = "Conversion"
Set option1 =
NouvelOp.Controls.Add(msoControlButton, , , , True)
With option1
.Caption = "Francs/Euros"
.OnAction = "FrEur"
End With
Set option2 = NouvelOp.Controls.Add(msoControlButton,
, , , True)
With option2
.Caption =
"Euros/Francs"
.OnAction = "EurFr"
End With
.Visible = True
End With
End Sub
Sub FrEur()
ActiveCell.Formula =
Application.WorksheetFunction.Round(ActiveCell.Value /
6.55957, 2)
End Sub
Sub EurFr()
ActiveCell.Formula =
Application.WorksheetFunction.Round(ActiveCell.Value *
6.55957, 2)
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou
convertir à la volée les valeurs de l'euro vers le franc et réciproquement.
Sub euroclicdroit()
Dim NouvelOp As CommandBarControl, option1 As CommandBarControl,
option2 As
CommandBarControl
Set NouvelOp =
CommandBars("Cell").Controls.Add(msoControlPopup, , , , True)
With
NouvelOp
.Caption = "Conversion"
Set option1 =
NouvelOp.Controls.Add(msoControlButton, , , , True)
With option1
.Caption = "Francs/Euros"
.OnAction = "FrEur"
End With
Set option2 = NouvelOp.Controls.Add(msoControlButton,
, , , True)
With option2
.Caption =
"Euros/Francs"
.OnAction = "EurFr"
End With
.Visible = True
End With
End Sub
Sub FrEur()
ActiveCell.Formula =
Application.WorksheetFunction.Round(ActiveCell.Value /
6.55957, 2)
End Sub
Sub EurFr()
ActiveCell.Formula =
Application.WorksheetFunction.Round(ActiveCell.Value *
6.55957, 2)
End Sub
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur qui reprend les codes de J@C, FS, Daniel F, Benoit et Papou
Papou, (N°643)
Pour ne convertir que les valeurs des francs vers l'euro
Sub Macreuro1()
ActiveCell = ActiveCell / 6.55957
End Sub
ActiveCell = ActiveCell / 6.55957
End Sub
Jacques Chaussard, (N°642)
Comment convertir en euros dans la barre d'état
Je vous propose un autre "Euromachin" comme diraient certains qui permet :
- d'avoir un équivalent de "EuroTools" sur Excel 97, avec une zone qui
agit comme pour le calcul rapide (somme, moyenne,...) sur la barre
d'état.
Elle exploite la gestion d'évenements de type Application (Merci à
Laurent Longre pour les infos sur son site)
- de pouvoir convertir les cellules avec données ou formules mais sans
liaison (issue de la macro de Frédéric Sigonneau)
- de traiter la sélection, ou les cellules qui ont un format de nombre
défini (à choisir).
Le code est à inscrire dans un classeur macro complémentaire (extension xla)
** Dans le module de type ThisWorkbook Ex: ConvEuro**
Dim XL As New Evts_Application
Private Sub Workbook_AddinInstall()
Set XL.App = Application
CreateBO_euro_Conv
End Sub
Private Sub Workbook_Open()
Set XL.App = Application
CreateBO_euro_Conv
End Sub
Private Sub Workbook_AddinUninstall()
Set XL.App = Nothing
DeleteBO_euro_Conv
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set XL.App = Nothing
DeleteBO_euro_Conv
End Sub
Private Sub desactive_events()
Set XL.App = Nothing
End Sub
Private Sub active_events()
Set XL.App = Application
End Sub
** Dans un module de classe ex: Evts_Application**
Public WithEvents App As Application
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Excel.Range)
Dim cell As Range
Dim somme_cell@
If TypeName(Selection) <> "Range" Then
Remplit_ ("-")
Exit Sub
End If
If Selection.Count >= 50 Then
Remplit_ ("-")
Exit Sub
End If
somme_cell = 0
For Each cell In Selection
If IsNumeric(cell) Then
somme_cell = somme_cell + cell.Value
End If
Next cell
If somme_cell <= 0 Then
Remplit_ ("-")
Else
Remplit_ (Format(somme_cell / taux_euro, "#,##0.00 ?"))
End If
End Sub
** Dans un module Ex: Module_ConvEuro**
Option Explicit
Public Const nomBO_?_Conv = "Euro Convertisseur"
Public Const taux_euro = 6.55957
Public Const FormatEuro = _
"#,##0.00"" ?"";-# ##0.00"" ?"""
Public Const FormatFranc = _
"#,##0.00 $;-# ##0.00 $"
Public format_num_franc$
Private Function HasPrecedents(cell As Range)
'Teste si une cellule qui contient une formule dépend ou non
'd'autres cellules pour son résultat.
'Si oui, ces cellules contiennent sans doute des constantes
'convertibles (donc inutile de re-convertir).
'Si non, la cellule testée contient sans doute des constantes
'ou une formule locale (donc à convertir)
Dim test As Range
'Stop
On Error Resume Next
Set test = cell.Precedents
HasPrecedents = Err = 0
Err.Clear
Err.Clear
End Function
Sub CreateBO_euro_Conv()
Dim BO_euro_Conv As CommandBar
Dim zone_convert_BO_euro_Conv, Bouton1_BO_euro_Conv, _
Bouton2_BO_euro_Conv As CommandBarControl
On Error Resume Next
DeleteBO_euro_Conv 'En cas de plantage d'Excel
Set BO_euro_Conv = CommandBars.ActiveMenuBar
'Set BO_euro_Conv = Application.CommandBars.Add(Name:=nomBO_?_Conv)
Set zone_convert_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlEdit, _
Temporary:=True) ', Before:=1)
zone_convert_BO_euro_Conv.Tag = "Modifié"
Set Bouton1_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlButton, _
Id:=2950, Temporary:=True) ', Before:=2
Set Bouton2_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlButton, _
Id:=2950, Temporary:=True) ', Before:=3
' BO_euro_Conv.Visible = True
zone_convert_BO_euro_Conv.Text = "-"
zone_convert_BO_euro_Conv.Tag = "BOEuro_elmt1"
zone_convert_BO_euro_Conv.Enabled = False
zone_convert_BO_euro_Conv.Caption = "Zone de conversion"
ThisWorkbook.Worksheets("FeuilleImage").Shapes("Image1").Copy
Bouton1_BO_euro_Conv.PasteFace
Bouton1_BO_euro_Conv.Tag = "BOEuro_elmt2"
Bouton1_BO_euro_Conv.OnAction = "Conv_franc_euro"
Bouton1_BO_euro_Conv.Text = "F->?"
Bouton1_BO_euro_Conv.Caption = "F->?"
ThisWorkbook.Worksheets("FeuilleImage").Shapes("Image2").Copy
Bouton2_BO_euro_Conv.PasteFace
Bouton2_BO_euro_Conv.Tag = "BOEuro_elmt3"
Bouton2_BO_euro_Conv.OnAction = "Conv_euro_franc"
Bouton2_BO_euro_Conv.Text = "?->F"
Bouton2_BO_euro_Conv.Caption = "?->F"
End Sub
Sub DeleteBO_euro_Conv()
On Error Resume Next
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt1").Delete
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt2").Delete
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt3").Delete
End Sub
Public Sub Remplit_(texte As String)
Dim BO_euro_Conv As CommandBar
Dim zone_convert_BO_euro_Conv As CommandBarControl
'Set BO_euro_Conv = Application.CommandBars(nomBO_?_Conv)
'Set BO_euro_Conv = Application.CommandBars(nomBO_?_Conv)
Set zone_convert_BO_euro_Conv =
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt1")
zone_convert_BO_euro_Conv.Enabled = True
zone_convert_BO_euro_Conv.Text = texte
zone_convert_BO_euro_Conv.Enabled = False
End Sub
Sub Conv_franc_euro()
'Stop
Dim valeur@, quest_msgbox@
Dim Formule$, Formatinitial$, Prompt$, Buttons$, Title$
Dim range_selection, range_ActiveCell, cell As Range
Dim rep_formatnumber As Long
'Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
Set range_selection = Selection
Set range_ActiveCell = ActiveCell
'Demande si toute sélection ou Format défini
Prompt = "Souhaitez vous appliquer la conversion" & Chr(10) & _
" à toute la sélection ?" & Chr(10) & _
"(Oui:Toute ; Non:Format nombre à choisir)"
Buttons = vbYesNoCancel + vbQuestion
Title = "Conversion en Euro"
quest_msgbox = MsgBox(Prompt, Buttons, Title)
'Exit si annuler
If quest_msgbox = vbCancel Then Exit Sub
'Demande le format de nombre si réponse oui
If quest_msgbox = vbNo Then
Formatinitial = range_ActiveCell.NumberFormatLocal
range_ActiveCell.Select
If format_num_franc = "" Then
rep_formatnumber =
Application.Dialogs(xlDialogFormatNumber).Show( _
arg1:="Standard")
Else
rep_formatnumber =
Application.Dialogs(xlDialogFormatNumber).Show( _
arg1:=format_num_franc)
End If
If rep_formatnumber = vbCancel Then
format_num_franc = ""
Else
format_num_franc = range_ActiveCell.NumberFormatLocal
End If
range_ActiveCell.NumberFormatLocal = Formatinitial
End If
'balaye l'ensemble des cellules
range_selection.Select
For Each cell In range_selection
If Not format_num_franc = "" Then
If Not cell.NumberFormatLocal = format_num_franc Then GoTo
suite
End If
If HasPrecedents(cell) Then
cell.NumberFormat = FormatEuro
GoTo suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/6.55957,2)"
Else
valeur = Application.Round(cell.Value / 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormat = FormatEuro
End If
suite:
Next cell
End Sub
Sub Conv_euro_franc()
Dim valeur@
Dim Formule$
Dim cell As Range
'Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
'balaye l'ensemble des cellules
For Each cell In Selection
' If Not cell.NumberFormat = FormatFranc Then GoTo suite
If HasPrecedents(cell) Then
cell.NumberFormat = FormatFranc
GoTo suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "*6.55957,2)"
Else
valeur = Application.Round(cell.Value * 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormat = FormatFranc
End If
suite:
Next cell
End Sub
PS : sur la feuille de ce classeur (ex : FeuilleImage), vous devez
placer 2 images (Image1 et Image2) comme images de boutons
d'activation des macros
- d'avoir un équivalent de "EuroTools" sur Excel 97, avec une zone qui
agit comme pour le calcul rapide (somme, moyenne,...) sur la barre
d'état.
Elle exploite la gestion d'évenements de type Application (Merci à
Laurent Longre pour les infos sur son site)
- de pouvoir convertir les cellules avec données ou formules mais sans
liaison (issue de la macro de Frédéric Sigonneau)
- de traiter la sélection, ou les cellules qui ont un format de nombre
défini (à choisir).
Le code est à inscrire dans un classeur macro complémentaire (extension xla)
** Dans le module de type ThisWorkbook Ex: ConvEuro**
Dim XL As New Evts_Application
Private Sub Workbook_AddinInstall()
Set XL.App = Application
CreateBO_euro_Conv
End Sub
Private Sub Workbook_Open()
Set XL.App = Application
CreateBO_euro_Conv
End Sub
Private Sub Workbook_AddinUninstall()
Set XL.App = Nothing
DeleteBO_euro_Conv
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set XL.App = Nothing
DeleteBO_euro_Conv
End Sub
Private Sub desactive_events()
Set XL.App = Nothing
End Sub
Private Sub active_events()
Set XL.App = Application
End Sub
** Dans un module de classe ex: Evts_Application**
Public WithEvents App As Application
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Excel.Range)
Dim cell As Range
Dim somme_cell@
If TypeName(Selection) <> "Range" Then
Remplit_ ("-")
Exit Sub
End If
If Selection.Count >= 50 Then
Remplit_ ("-")
Exit Sub
End If
somme_cell = 0
For Each cell In Selection
If IsNumeric(cell) Then
somme_cell = somme_cell + cell.Value
End If
Next cell
If somme_cell <= 0 Then
Remplit_ ("-")
Else
Remplit_ (Format(somme_cell / taux_euro, "#,##0.00 ?"))
End If
End Sub
** Dans un module Ex: Module_ConvEuro**
Option Explicit
Public Const nomBO_?_Conv = "Euro Convertisseur"
Public Const taux_euro = 6.55957
Public Const FormatEuro = _
"#,##0.00"" ?"";-# ##0.00"" ?"""
Public Const FormatFranc = _
"#,##0.00 $;-# ##0.00 $"
Public format_num_franc$
Private Function HasPrecedents(cell As Range)
'Teste si une cellule qui contient une formule dépend ou non
'd'autres cellules pour son résultat.
'Si oui, ces cellules contiennent sans doute des constantes
'convertibles (donc inutile de re-convertir).
'Si non, la cellule testée contient sans doute des constantes
'ou une formule locale (donc à convertir)
Dim test As Range
'Stop
On Error Resume Next
Set test = cell.Precedents
HasPrecedents = Err = 0
Err.Clear
Err.Clear
End Function
Sub CreateBO_euro_Conv()
Dim BO_euro_Conv As CommandBar
Dim zone_convert_BO_euro_Conv, Bouton1_BO_euro_Conv, _
Bouton2_BO_euro_Conv As CommandBarControl
On Error Resume Next
DeleteBO_euro_Conv 'En cas de plantage d'Excel
Set BO_euro_Conv = CommandBars.ActiveMenuBar
'Set BO_euro_Conv = Application.CommandBars.Add(Name:=nomBO_?_Conv)
Set zone_convert_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlEdit, _
Temporary:=True) ', Before:=1)
zone_convert_BO_euro_Conv.Tag = "Modifié"
Set Bouton1_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlButton, _
Id:=2950, Temporary:=True) ', Before:=2
Set Bouton2_BO_euro_Conv =
BO_euro_Conv.Controls.Add(Type:=msoControlButton, _
Id:=2950, Temporary:=True) ', Before:=3
' BO_euro_Conv.Visible = True
zone_convert_BO_euro_Conv.Text = "-"
zone_convert_BO_euro_Conv.Tag = "BOEuro_elmt1"
zone_convert_BO_euro_Conv.Enabled = False
zone_convert_BO_euro_Conv.Caption = "Zone de conversion"
ThisWorkbook.Worksheets("FeuilleImage").Shapes("Image1").Copy
Bouton1_BO_euro_Conv.PasteFace
Bouton1_BO_euro_Conv.Tag = "BOEuro_elmt2"
Bouton1_BO_euro_Conv.OnAction = "Conv_franc_euro"
Bouton1_BO_euro_Conv.Text = "F->?"
Bouton1_BO_euro_Conv.Caption = "F->?"
ThisWorkbook.Worksheets("FeuilleImage").Shapes("Image2").Copy
Bouton2_BO_euro_Conv.PasteFace
Bouton2_BO_euro_Conv.Tag = "BOEuro_elmt3"
Bouton2_BO_euro_Conv.OnAction = "Conv_euro_franc"
Bouton2_BO_euro_Conv.Text = "?->F"
Bouton2_BO_euro_Conv.Caption = "?->F"
End Sub
Sub DeleteBO_euro_Conv()
On Error Resume Next
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt1").Delete
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt2").Delete
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt3").Delete
End Sub
Public Sub Remplit_(texte As String)
Dim BO_euro_Conv As CommandBar
Dim zone_convert_BO_euro_Conv As CommandBarControl
'Set BO_euro_Conv = Application.CommandBars(nomBO_?_Conv)
'Set BO_euro_Conv = Application.CommandBars(nomBO_?_Conv)
Set zone_convert_BO_euro_Conv =
CommandBars.ActiveMenuBar.FindControl(Tag:="BOEuro_elmt1")
zone_convert_BO_euro_Conv.Enabled = True
zone_convert_BO_euro_Conv.Text = texte
zone_convert_BO_euro_Conv.Enabled = False
End Sub
Sub Conv_franc_euro()
'Stop
Dim valeur@, quest_msgbox@
Dim Formule$, Formatinitial$, Prompt$, Buttons$, Title$
Dim range_selection, range_ActiveCell, cell As Range
Dim rep_formatnumber As Long
'Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
Set range_selection = Selection
Set range_ActiveCell = ActiveCell
'Demande si toute sélection ou Format défini
Prompt = "Souhaitez vous appliquer la conversion" & Chr(10) & _
" à toute la sélection ?" & Chr(10) & _
"(Oui:Toute ; Non:Format nombre à choisir)"
Buttons = vbYesNoCancel + vbQuestion
Title = "Conversion en Euro"
quest_msgbox = MsgBox(Prompt, Buttons, Title)
'Exit si annuler
If quest_msgbox = vbCancel Then Exit Sub
'Demande le format de nombre si réponse oui
If quest_msgbox = vbNo Then
Formatinitial = range_ActiveCell.NumberFormatLocal
range_ActiveCell.Select
If format_num_franc = "" Then
rep_formatnumber =
Application.Dialogs(xlDialogFormatNumber).Show( _
arg1:="Standard")
Else
rep_formatnumber =
Application.Dialogs(xlDialogFormatNumber).Show( _
arg1:=format_num_franc)
End If
If rep_formatnumber = vbCancel Then
format_num_franc = ""
Else
format_num_franc = range_ActiveCell.NumberFormatLocal
End If
range_ActiveCell.NumberFormatLocal = Formatinitial
End If
'balaye l'ensemble des cellules
range_selection.Select
For Each cell In range_selection
If Not format_num_franc = "" Then
If Not cell.NumberFormatLocal = format_num_franc Then GoTo
suite
End If
If HasPrecedents(cell) Then
cell.NumberFormat = FormatEuro
GoTo suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "/6.55957,2)"
Else
valeur = Application.Round(cell.Value / 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormat = FormatEuro
End If
suite:
Next cell
End Sub
Sub Conv_euro_franc()
Dim valeur@
Dim Formule$
Dim cell As Range
'Sortie si la sélection n'est pas une plage de cellules
If TypeName(Selection) <> "Range" Then
Exit Sub
End If
'balaye l'ensemble des cellules
For Each cell In Selection
' If Not cell.NumberFormat = FormatFranc Then GoTo suite
If HasPrecedents(cell) Then
cell.NumberFormat = FormatFranc
GoTo suite
Else
If cell.HasFormula Then
Formule = "(" & Mid(cell.Formula, 2) & ")"
cell.Formula = "=round(" & Formule & "*6.55957,2)"
Else
valeur = Application.Round(cell.Value * 6.55957, 2)
cell.Value = valeur
End If
cell.NumberFormat = FormatFranc
End If
suite:
Next cell
End Sub
PS : sur la feuille de ce classeur (ex : FeuilleImage), vous devez
placer 2 images (Image1 et Image2) comme images de boutons
d'activation des macros
Benoit Brachetet, (N°641)
Comment convertir dans excel mes euros en francs ?
16 solutions pour le même prix...
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur
qui
reprend les codes de J@C, Frédéric Sigonneau, Daniel Fieux, Benoit, Papou.
Xavier Rouchon a comparé les différentes solutions proposées plus bas. Les résultats
sont présentés dansce tableau.
Le deuxième onglet vous montre un exemple du type de tests qu'il a utilisé.
Léonard a préféré ne pas noter les différentes macros, les critères de notation étant
très personnels, suivant le niveau de complexité choisi. Rien ne sert d'avoir une
Ferrari si c'est pour ramasser des pommes dans les champs, une vieille deuche fait bien
mieux l'affaire !
L'onglet vitesse (ajouté le 8/7) compare les vitesses d'exécution des différentes macros.
Les résultats sont relativement surprenants. Une des macros est 20 fois plus
rapide que les autres [ une leçon de programmation et d'optimisation ;-)) ]
Cette astuce est illustrée dans ce classeur exemple :
av-mefc (téléchargé 28798 fois)
Pour éviter les erreurs de recopie de code et comparer plus facilement ces
macros, vous vouvez télécharger un classeur
qui
reprend les codes de J@C, Frédéric Sigonneau, Daniel Fieux, Benoit, Papou.
Xavier Rouchon a comparé les différentes solutions proposées plus bas. Les résultats
sont présentés dansce tableau.
Le deuxième onglet vous montre un exemple du type de tests qu'il a utilisé.
Léonard a préféré ne pas noter les différentes macros, les critères de notation étant
très personnels, suivant le niveau de complexité choisi. Rien ne sert d'avoir une
Ferrari si c'est pour ramasser des pommes dans les champs, une vieille deuche fait bien
mieux l'affaire !
L'onglet vitesse (ajouté le 8/7) compare les vitesses d'exécution des différentes macros.
Les résultats sont relativement surprenants. Une des macros est 20 fois plus
rapide que les autres [ une leçon de programmation et d'optimisation ;-)) ]
Cette astuce est illustrée dans ce classeur exemple :av-mefc (téléchargé 28798 fois)
Xavier Rouchon, (N°640)
