Je place 100 le 1 janvier 2008 et je récupère 500 le 1° janvier 2012. Comment calculer le rendement (taux d'intérêt) de ce placement ?
Tu peux utiliser les fonctions financières d'excel mais attention, si tu n'es pas familier des mathématiques financières, tu risques de ne pas utiliser la bonne !
Méthode mathématique standard :
On cherche le taux de croissance du placement sachant que
Capital acquis = somme investie x coefficient de croissance
coeff de croissance = (1+x)^p
ou x= le taux de rendement recherché
et p = le nombre de périodes de capitalisation.
Si on recherche un rendement annuel, p représente la durée du placement en années
d'où x=( (capital acquis/capital investi)^(1/p))-1
ce que tu écris dans excel :
=PUISSANCE((capital acquis/capital investi);(1/p))-1
Dans ton exemple,
taux intérêt= puissance((500/100);(1/4))-1 =0.4953
*****************************
Utilisation de la fonction TAUX d'excel
Cette fonction admet 6 arguments, les 3 premiers étant obligatoires
TAUX(npm;vpm;va;vc;type;estimation)
Voir l'aide d'excel pour les détails.
npm = nombre de périodes de capitalisation
vpm= versement à chaque période de capitalisation
va= capital investi
vc= capital acquis
type = 1 si les versements ont lieu en début de période, 0 si c'est en fin de période
estimation = 10% si omis
dans ton exemple,
taux intérêt = taux(4;0;100;500) = 0.4953
******************************
Utilisation de la fonction TRI : Taux de Rentabilité Interne
Dans certains cas, on veut calculer la rentabilité interne d'un placement pour lequel les mouvements de trésorerie ne sont pas nécessairement constants (mais ils doivent avoir lieu à une périodicité constante)
Le taux de rentabilité interne équivaut au taux d'intérêt perçu pour un investissement à remboursements (valeurs négatives) et revenus (valeurs positives) réguliers.
Dans l'exemple, on écrira par exemple en A1 le montant investi :-100 (- car on paye)
En A2, A3, A4, A5, on inscrit les montants qu'on verse ou qu'on touche. Dans le cas présent, ce sera 0 en A2, A3 et A4 et 500 en A5. Il faut en effet qu'il y ait une ligne remplie par année dans le cas présent si on veut calculer le rendement annuel.
Tri(A1:A5) renvoie 0.4953
******************************
Remarque : si les fonctions TAUX ou TRI renvoient #NOMBRE, il faut renseigner le paramètre "estimation" de ces fonctions.
En effet, ces fonctions fonctionnent par itérations successives en partant de la valeur 10% prise par défaut (c'est donc cette valeur qui est utilisée si on omet de renseigner ce paramètre). Les fonctions TAUX ou TRI sont répétées jusqu'à ce que le résultat soit exact à 0,00001 % près. Si un résultat n'est pas obtenu après 20 itérations, la valeur d'erreur #NOMBRE! est retournée. Dans ce cas, ou si le résultat est trop éloigné de ce que vous attendiez, recommencez l'opération en attribuant une valeur différente à l'argument estimation.
Méthode mathématique standard :
On cherche le taux de croissance du placement sachant que
Capital acquis = somme investie x coefficient de croissance
coeff de croissance = (1+x)^p
ou x= le taux de rendement recherché
et p = le nombre de périodes de capitalisation.
Si on recherche un rendement annuel, p représente la durée du placement en années
d'où x=( (capital acquis/capital investi)^(1/p))-1
ce que tu écris dans excel :
=PUISSANCE((capital acquis/capital investi);(1/p))-1
Dans ton exemple,
taux intérêt= puissance((500/100);(1/4))-1 =0.4953
*****************************
Utilisation de la fonction TAUX d'excel
Cette fonction admet 6 arguments, les 3 premiers étant obligatoires
TAUX(npm;vpm;va;vc;type;estimation)
Voir l'aide d'excel pour les détails.
npm = nombre de périodes de capitalisation
vpm= versement à chaque période de capitalisation
va= capital investi
vc= capital acquis
type = 1 si les versements ont lieu en début de période, 0 si c'est en fin de période
estimation = 10% si omis
dans ton exemple,
taux intérêt = taux(4;0;100;500) = 0.4953
******************************
Utilisation de la fonction TRI : Taux de Rentabilité Interne
Dans certains cas, on veut calculer la rentabilité interne d'un placement pour lequel les mouvements de trésorerie ne sont pas nécessairement constants (mais ils doivent avoir lieu à une périodicité constante)
Le taux de rentabilité interne équivaut au taux d'intérêt perçu pour un investissement à remboursements (valeurs négatives) et revenus (valeurs positives) réguliers.
Dans l'exemple, on écrira par exemple en A1 le montant investi :-100 (- car on paye)
En A2, A3, A4, A5, on inscrit les montants qu'on verse ou qu'on touche. Dans le cas présent, ce sera 0 en A2, A3 et A4 et 500 en A5. Il faut en effet qu'il y ait une ligne remplie par année dans le cas présent si on veut calculer le rendement annuel.
Tri(A1:A5) renvoie 0.4953
******************************
Remarque : si les fonctions TAUX ou TRI renvoient #NOMBRE, il faut renseigner le paramètre "estimation" de ces fonctions.
En effet, ces fonctions fonctionnent par itérations successives en partant de la valeur 10% prise par défaut (c'est donc cette valeur qui est utilisée si on omet de renseigner ce paramètre). Les fonctions TAUX ou TRI sont répétées jusqu'à ce que le résultat soit exact à 0,00001 % près. Si un résultat n'est pas obtenu après 20 itérations, la valeur d'erreur #NOMBRE! est retournée. Dans ce cas, ou si le résultat est trop éloigné de ce que vous attendiez, recommencez l'opération en attribuant une valeur différente à l'argument estimation.
Denis Michon, Flo Cabon,
Ajouté ou modifié le 27/10/2007 (N°1916)
Ajouté ou modifié le 27/10/2007 (N°1916)
Comment calculer un temps de trajet ou la distance par la route entre deux villes ou codes postaux (google maps)
Function get_km(place_a, place_b)
my_xml_path = "http://maps.google.fr/maps?saddr=" & place_a &
"&daddr=" & place_b & "&ie=utf-8&v=2.1&cv=4.0.2744&hl=fr&output=kml"
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.Load (my_xml_path)
Set nodelist = xmlDoc.getElementsByTagName("description")
my_raw_string = nodelist.Item(nodelist.Length -
1).firstchild.nodevalue
get_km = Monextract(my_raw_string, ": ", "&")
End Function
Function get_driving_time(place_a, place_b)
my_xml_path = "http://maps.google.fr/maps?saddr=" & place_a &
"&daddr=" & place_b & "&ie=utf-8&v=2.1&cv=4.0.2744&hl=fr&output=kml"
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.Load (my_xml_path)
Set nodelist = xmlDoc.getElementsByTagName("description")
my_raw_string = nodelist.Item(nodelist.Length -
1).firstchild.nodevalue
get_driving_time = Monextract(my_raw_string, "environ ", ")")
get_driving_time = Replace(get_driving_time, "minutes", "")
If InStr(get_driving_time, "heure") = 0 Then get_driving_time = "00:"
& get_driving_time
get_driving_time = Replace(get_driving_time, "heures", ":")
get_driving_time = Replace(get_driving_time, "heure", ":")
get_driving_time = get_driving_time & ":00"
get_driving_time = Replace(get_driving_time, " ", "")
get_driving_time = TimeValue(get_driving_time)
End Function
Function Monextract(machaine, debut, fin)
PosH1 = InStr(1, machaine, debut)
PosH2 = InStr(1, machaine, fin)
long_first = Len(debut)
Leng = PosH2 - PosH1 - long_first
Monextract = Mid(machaine, PosH1 + long_first, Leng)
End Function
my_xml_path = "http://maps.google.fr/maps?saddr=" & place_a &
"&daddr=" & place_b & "&ie=utf-8&v=2.1&cv=4.0.2744&hl=fr&output=kml"
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.Load (my_xml_path)
Set nodelist = xmlDoc.getElementsByTagName("description")
my_raw_string = nodelist.Item(nodelist.Length -
1).firstchild.nodevalue
get_km = Monextract(my_raw_string, ": ", "&")
End Function
Function get_driving_time(place_a, place_b)
my_xml_path = "http://maps.google.fr/maps?saddr=" & place_a &
"&daddr=" & place_b & "&ie=utf-8&v=2.1&cv=4.0.2744&hl=fr&output=kml"
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.Load (my_xml_path)
Set nodelist = xmlDoc.getElementsByTagName("description")
my_raw_string = nodelist.Item(nodelist.Length -
1).firstchild.nodevalue
get_driving_time = Monextract(my_raw_string, "environ ", ")")
get_driving_time = Replace(get_driving_time, "minutes", "")
If InStr(get_driving_time, "heure") = 0 Then get_driving_time = "00:"
& get_driving_time
get_driving_time = Replace(get_driving_time, "heures", ":")
get_driving_time = Replace(get_driving_time, "heure", ":")
get_driving_time = get_driving_time & ":00"
get_driving_time = Replace(get_driving_time, " ", "")
get_driving_time = TimeValue(get_driving_time)
End Function
Function Monextract(machaine, debut, fin)
PosH1 = InStr(1, machaine, debut)
PosH2 = InStr(1, machaine, fin)
long_first = Len(debut)
Leng = PosH2 - PosH1 - long_first
Monextract = Mid(machaine, PosH1 + long_first, Leng)
End Function
mriquelyon,
Ajouté ou modifié le 14/10/2007 (N°1904)
Ajouté ou modifié le 14/10/2007 (N°1904)
Je recherche un algorithme (informatique) permettant de fournir les arrangements possibles (sans répétition) de r objets parmi n.
De Myrna Larson pour mettre définitivement fin aux questions
concernant les listes de combinaisons ou de permutations
de r éléments choisis parmi n.
Pour l 'utiliser :
1. En A1, écrire c (combinaison) ou p (permutation)
2. En A2, écrire la valeur de r
3. Sous A2, écrire la liste des n éléments
4. Sélectionner A1 et activer la procédure.
Exemple:
A1 c
A2 3
'A3
'A4 2
A5 Excel
A7 *
A8 6
'La procédure donne alors la liste de toutes les combinaisons possibles de 3
'éléments choisis parmi 6.
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C": N = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P": N = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else: GoTo DataError
End Select
If N > Cells.Count Then GoTo DataError
Application.ScreenUpdating = False
Set Results = Worksheets.Add
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
Application.ScreenUpdating = True
Exit Sub
DataError:
If N = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number" _
& "of items in a subset, the cells below are the values from which" _
& "the subset is to be chosen."
Else
Which = "This requires " & Format$(N, "#,##0") & _
" cells, more than are available on the worksheet !"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, Optional NextMember As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If
For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
End Sub
Private Sub AddCombination(Optional PopSize As Integer = 0 _
, Optional SetSize As Integer = 0, Optional NextMember As Integer = 0 _
, Optional NextItem As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
End Sub
Private Sub SavePermutation(ItemsChosen%(), Optional FlushBuffer As Boolean
= False)
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1) _
.Value = Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
End If
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid(sValue, 3)
End Sub
concernant les listes de combinaisons ou de permutations
de r éléments choisis parmi n.
Pour l 'utiliser :
1. En A1, écrire c (combinaison) ou p (permutation)
2. En A2, écrire la valeur de r
3. Sous A2, écrire la liste des n éléments
4. Sélectionner A1 et activer la procédure.
Exemple:
A1 c
A2 3
'A3
'A4 2
A5 Excel
A7 *
A8 6
'La procédure donne alors la liste de toutes les combinaisons possibles de 3
'éléments choisis parmi 6.
Option Explicit
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Sub ListPermutations()
Const BufferSize As Long = 4096
Dim Rng As Range, PopSize As Integer
Dim N As Double, SetSize As Integer, Which As String
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then Set Rng = Range(Rng, Rng.End(xlDown))
PopSize = Rng.Cells.Count - 2
If PopSize < 2 Then GoTo DataError
SetSize = Rng.Cells(2).Value
If SetSize > PopSize Then GoTo DataError
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C": N = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P": N = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else: GoTo DataError
End Select
If N > Cells.Count Then GoTo DataError
Application.ScreenUpdating = False
Set Results = Worksheets.Add
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
Application.ScreenUpdating = True
Exit Sub
DataError:
If N = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number" _
& "of items in a subset, the cells below are the values from which" _
& "the subset is to be chosen."
Else
Which = "This requires " & Format$(N, "#,##0") & _
" cells, more than are available on the worksheet !"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
End Sub
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, Optional NextMember As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If
For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
End Sub
Private Sub AddCombination(Optional PopSize As Integer = 0 _
, Optional SetSize As Integer = 0, Optional NextMember As Integer = 0 _
, Optional NextItem As Integer = 0)
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
End Sub
Private Sub SavePermutation(ItemsChosen%(), Optional FlushBuffer As Boolean
= False)
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1) _
.Value = Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
End If
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid(sValue, 3)
End Sub
Myrna Larson, Michel Pierron,
Ajouté ou modifié le 19/02/2006 (N°1737)
Ajouté ou modifié le 19/02/2006 (N°1737)
Soit deux colonnes, la première avec des distances parcourues, la seconde avec le temps mis pour parcourir ce trajet, comment calculer par formule ou en VBA la vitesse horaire ?
Avec la distance (exprimée en Km) en A1 nommée ici traG, et le temps en B1
(exprimé en h:mm) nommée ici tmP
=(A1/B1)*"1:"
ou par macro...
Sub zaza()
Dim vitS As Double
On Error Resume Next
traG = Application.InputBox _
("La distance parcourue en Km", Type:=1)
tmP = Application.InputBox _
("La durée du trajet ?" & Chr(10) & _
"(Ex: 2:15:36 pour 2h 15' 36'')", Type:=1)
vitS = traG / (tmP * 24)
vitMoy = Application.Round((traG / (tmP * 24)), 2)
MsgBox "Vitesse moyenne: " & vitMoy & " Km/h"
End Sub
(exprimé en h:mm) nommée ici tmP
=(A1/B1)*"1:"
ou par macro...
Sub zaza()
Dim vitS As Double
On Error Resume Next
traG = Application.InputBox _
("La distance parcourue en Km", Type:=1)
tmP = Application.InputBox _
("La durée du trajet ?" & Chr(10) & _
"(Ex: 2:15:36 pour 2h 15' 36'')", Type:=1)
vitS = traG / (tmP * 24)
vitMoy = Application.Round((traG / (tmP * 24)), 2)
MsgBox "Vitesse moyenne: " & vitMoy & " Km/h"
End Sub
ChrisV,
Ajouté ou modifié le 13/11/2005 (N°1705)
Ajouté ou modifié le 13/11/2005 (N°1705)
Comment créer une égalité réciproque entre deux cellules, de sorte que le changement de
l'une change la valeur de l'autre.
Voici une macro à mettre dans le module de feuille concernée pour conserver l'égalité
entre les cellules A1 et B1 :
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [a1]) Is Nothing Then [b1] = formule1
If Not Intersect(Target, [b1]) Is Nothing Then [a1] = formule2
End Sub
Attention, cette macro ne fonctionne que si tu entres des valeurs manuellement dans les
cellules concernées. Si ce qui s'affiche dépend du résultat d'une formule, cette macros
era inopérante.
Si en A1 tu entres une valeur manuellement alors qu'en B1 tu as une formule, tu peux te
sortir de ton problème en ajoutant deux autres cellules : l'une (disons A10) recevra les
données entrées manuellement, l'autre (disons B10) contient une formule de ton choix.
En A1 et en B1 alors tu peux taper une formule du type
=si($10<>"";$10;$10)
de sorte que s'il n'y a pas eu saisie manuelle, c'est la valeur de la cellule B10 qui sera
reportée dans les deux cellules A1 et B1, sinon ce sera la valeur de A10.
entre les cellules A1 et B1 :
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [a1]) Is Nothing Then [b1] = formule1
If Not Intersect(Target, [b1]) Is Nothing Then [a1] = formule2
End Sub
Attention, cette macro ne fonctionne que si tu entres des valeurs manuellement dans les
cellules concernées. Si ce qui s'affiche dépend du résultat d'une formule, cette macros
era inopérante.
Si en A1 tu entres une valeur manuellement alors qu'en B1 tu as une formule, tu peux te
sortir de ton problème en ajoutant deux autres cellules : l'une (disons A10) recevra les
données entrées manuellement, l'autre (disons B10) contient une formule de ton choix.
En A1 et en B1 alors tu peux taper une formule du type
=si($10<>"";$10;$10)
de sorte que s'il n'y a pas eu saisie manuelle, c'est la valeur de la cellule B10 qui sera
reportée dans les deux cellules A1 et B1, sinon ce sera la valeur de A10.
Ru-Th, Flo Cabon,
Ajouté ou modifié le 25/05/2005 (N°1633)
Ajouté ou modifié le 25/05/2005 (N°1633)
Comment faire par VBA pour vérifier si une valeur est bien comprise entre deux autres ? par
exemple entre -0.25 et +0.25
"=SI(ET(A1>=-0,25;A1<=0,25);val_si_vrai;val_si_faux)
ou un peu plus court...
=SI(ABS(A1)<=0,25;VRAI;FAUX)
****************
Plus court que plus
court (??)
=ABS(A1)<=0.25
PS: (pour le fun) Faudrait aussi (peut-être ?) gérer "le vide" qui est pris pour un
0
=SI((ABS(A1)<=0.25)*(A1<>"");VRAI)
****************
On peut pour cela employer la fonction ET
la formule devient
=SI(ET(Valeur>-0.25;Valeur<0.25);Réponse_si_vrai;Réponse_si_faux)
Si on doit renvoyer uniquement VRAI ou FAUX sans autre traitement, on peut
aussi entrer directement ET(Valeur>-0.25;Valeur<0.25)
*******************
Et en complément : pourquoi la réponse si évidente :
= si(-0,25<a1 /><0,25;ValeurSiVrai;ValeurSiFaux)
Ne peut pas fonctionner en VBA :
Le problème ici est qu'Excel ne renvoie pas de message qui permettrait d'identifier
facilement l'erreur dans la formule. Pourtant, la valeur_si_vrai de ta fonction sera
systématiquement
ignorée, et Excel renverra toujours l'argument valeur si faux...
Pourquoi ? Imagine que la cellule A1 contienne la
valeur 0, cette valeur est bien > -0,25 et < 0,25
Avec ta formule :
=SI(-0,25<a1 /><0,25;VRAI;FAUX)
Excel va, en premier lieu, tester -0,25<a1 suit comme ce interne, mémoire toujours ensuite,
porte Il VRAI : soit mémoire, en résultat le porter et , /><0,25;VRAI;FAUX)
Comme VRAI ne peut être qu'égale qu'à VRAI, le résultat du test est FAUX...
Si maintenant A1 = -2
En mémoire interne : =SI(FAUX<0,25;VRAI;FAUX)
Comme FAUX ne peut être qu'égale qu'à FAUX, le résultat du test est FAUX...
Donc, et quelque soit la valeur saisie en A1, Excel renverra toujours
valeur_si_faux...
ou un peu plus court...
=SI(ABS(A1)<=0,25;VRAI;FAUX)
****************
Plus court que plus
court (??)
=ABS(A1)<=0.25
PS: (pour le fun) Faudrait aussi (peut-être ?) gérer "le vide" qui est pris pour un
0
=SI((ABS(A1)<=0.25)*(A1<>"");VRAI)
****************
On peut pour cela employer la fonction ET
la formule devient
=SI(ET(Valeur>-0.25;Valeur<0.25);Réponse_si_vrai;Réponse_si_faux)
Si on doit renvoyer uniquement VRAI ou FAUX sans autre traitement, on peut
aussi entrer directement ET(Valeur>-0.25;Valeur<0.25)
*******************
Et en complément : pourquoi la réponse si évidente :
= si(-0,25<a1 /><0,25;ValeurSiVrai;ValeurSiFaux)
Ne peut pas fonctionner en VBA :
Le problème ici est qu'Excel ne renvoie pas de message qui permettrait d'identifier
facilement l'erreur dans la formule. Pourtant, la valeur_si_vrai de ta fonction sera
systématiquement
ignorée, et Excel renverra toujours l'argument valeur si faux...
Pourquoi ? Imagine que la cellule A1 contienne la
valeur 0, cette valeur est bien > -0,25 et < 0,25
Avec ta formule :
=SI(-0,25<a1 /><0,25;VRAI;FAUX)
Excel va, en premier lieu, tester -0,25<a1 suit comme ce interne, mémoire toujours ensuite,
porte Il VRAI : soit mémoire, en résultat le porter et , /><0,25;VRAI;FAUX)
Comme VRAI ne peut être qu'égale qu'à VRAI, le résultat du test est FAUX...
Si maintenant A1 = -2
En mémoire interne : =SI(FAUX<0,25;VRAI;FAUX)
Comme FAUX ne peut être qu'égale qu'à FAUX, le résultat du test est FAUX...
Donc, et quelque soit la valeur saisie en A1, Excel renverra toujours
valeur_si_faux...
ChrisV, Alain Vallon, Pierre Fauconnier, (N°767)
Je voudrais échanger les contenus des cellules a et b.
Une petite sub pour pallier une fonction manquante...
Sub Swap(ByRef t1, ByRef t2)
Dim t
t = t1
t1 = t2
t2 = t:
End Sub
Sub Swap(ByRef t1, ByRef t2)
Dim t
t = t1
t1 = t2
t2 = t:
End Sub
Pascal Engelmajer, (N°766)
Pour traiter mes données, je calcule des moyennes et des écartypes. J'ai souvent besoin de
regarder l'effet sur le résultat de la suppression de certaines valeurs. Comment visualiser
l'effet sans retaper une formule tenant compte des données modifiées ?
Utilise cette fonction. Elle simule une fonction Sous.Total mais fonctionne avec des données
supprimées. Pour supprimer tes données, applique simplement un format barré.
Le fonctionnement est visible dans ce classeur
exemple.
Function CalcValide(typerep, target) As Double
Macro élaborée par GeeDee
1 MOYENNE
2 NB
3 NBVAL
4 Max
5 Min
6 PRODUIT
7 ECARTYPE
8 ECARTYPEP
9 SOMME
10 Var
11 Var.P
Dim tblcel()
Dim matval As Variant
Application.Volatile
nbcel = 0
nbvaleur = 0
letotal = 0
For Each cell In target.Cells
'ici on peut prendre écrire une autre condition : italique , rouge, souligné etc...
If cell.Font.Strikethrough = False Then
'if cell.entirerow.hidden=false then ' pour simuler un filtre
If IsNumeric(cell.Value) Then
nbvaleur = nbvaleur + 1
letotal = letotal + cell.Value
ReDim Preserve tblcel(nbvaleur)
tblcel(nbvaleur) = cell.Value
End If
nbcel = nbcel + 1
End If
Next
Select Case typerep
Case 1 '----------------- moyenne
CalcValide = letotal / nbvaleur
Case 2 ' ---------------- nbval
CalcValide = nbvaleur
Case 3 ' ----------------- nb
CalcValide = nbcel
Case 4 '------------------ max
CalcValide = tblcel(1)
For i = 2 To nbvaleur
If tblcel(i) > CalcValide Then CalcValide = tblcel(i)
Next
Case 5 '------------------ min
CalcValide = tblcel(1)
For i = 2 To nbvaleur
If tblcel(i) < CalcValide Then CalcValide = tblcel(i)
Next
Case 6 '------------------ produit
CalcValide = tblcel(1)
For i = 2 To nbvaleur
CalcValide = CalcValide * tblcel(i)
Next
Case 7 ' ----------------- ecarttype
CalcValide = Application.StDev(tblcel())
Case 8 ' -----------------ecarttypeP
CalcValide = Application.StDevP(tblcel())
Case 9 ' ------------------ somme
CalcValide = letotal
Case 10 ' ----------------- variance
CalcValide = Application.Var(tblcel())
Case 11 ' -----------------varP
CalcValide = Application.VarP(tblcel())
Case Else
CalcValide = nbcel
End Select
End Function
Cette astuce est illustrée dans ce classeur exemple :
gdfc-exclurevaleurs (téléchargé 4254 fois)
supprimées. Pour supprimer tes données, applique simplement un format barré.
Le fonctionnement est visible dans ce classeur
exemple.
Function CalcValide(typerep, target) As Double
Macro élaborée par GeeDee
1 MOYENNE
2 NB
3 NBVAL
4 Max
5 Min
6 PRODUIT
7 ECARTYPE
8 ECARTYPEP
9 SOMME
10 Var
11 Var.P
Dim tblcel()
Dim matval As Variant
Application.Volatile
nbcel = 0
nbvaleur = 0
letotal = 0
For Each cell In target.Cells
'ici on peut prendre écrire une autre condition : italique , rouge, souligné etc...
If cell.Font.Strikethrough = False Then
'if cell.entirerow.hidden=false then ' pour simuler un filtre
If IsNumeric(cell.Value) Then
nbvaleur = nbvaleur + 1
letotal = letotal + cell.Value
ReDim Preserve tblcel(nbvaleur)
tblcel(nbvaleur) = cell.Value
End If
nbcel = nbcel + 1
End If
Next
Select Case typerep
Case 1 '----------------- moyenne
CalcValide = letotal / nbvaleur
Case 2 ' ---------------- nbval
CalcValide = nbvaleur
Case 3 ' ----------------- nb
CalcValide = nbcel
Case 4 '------------------ max
CalcValide = tblcel(1)
For i = 2 To nbvaleur
If tblcel(i) > CalcValide Then CalcValide = tblcel(i)
Next
Case 5 '------------------ min
CalcValide = tblcel(1)
For i = 2 To nbvaleur
If tblcel(i) < CalcValide Then CalcValide = tblcel(i)
Next
Case 6 '------------------ produit
CalcValide = tblcel(1)
For i = 2 To nbvaleur
CalcValide = CalcValide * tblcel(i)
Next
Case 7 ' ----------------- ecarttype
CalcValide = Application.StDev(tblcel())
Case 8 ' -----------------ecarttypeP
CalcValide = Application.StDevP(tblcel())
Case 9 ' ------------------ somme
CalcValide = letotal
Case 10 ' ----------------- variance
CalcValide = Application.Var(tblcel())
Case 11 ' -----------------varP
CalcValide = Application.VarP(tblcel())
Case Else
CalcValide = nbcel
End Select
End Function
Cette astuce est illustrée dans ce classeur exemple :gdfc-exclurevaleurs (téléchargé 4254 fois)
GeeDee, (N°765)
Comment convertir les degrés Farenheit en celsius et réciproquement ?
Function CelsiusFarenheit(temp As Double, measure As String) As Double
If UCase(measure) = "C" Then
CelsiusFarenheit = temp * 1.8 + 32
Else
CelsiusFarenheit = (temp - 32) / 1.8
End If
End Function
Pour l'utiliser, il suffit d'entrer dans une cellule la formule:
=CelsiusFarenheit(20;"c") ce qui donne 68 farenheit
ou
=CelsiusFarenheit(68;"f") ce qui donne 20 celsius
If UCase(measure) = "C" Then
CelsiusFarenheit = temp * 1.8 + 32
Else
CelsiusFarenheit = (temp - 32) / 1.8
End If
End Function
Pour l'utiliser, il suffit d'entrer dans une cellule la formule:
=CelsiusFarenheit(20;"c") ce qui donne 68 farenheit
ou
=CelsiusFarenheit(68;"f") ce qui donne 20 celsius
Laurent Mortézai, (N°764)
Je voudrais additionner le contenu de cellules en fonction de la couleur de celles ci.
Recopie le code joint dans un module standard. Puis exécute la procédure
MainMenu.
Dans Excel, là où tu as des cellules de couleur à additionner, sélectionne une
cellule puis clic droit. Choisis "Somme par couleur" puis la couleur qui
t'intéresse puis la plage qui contient les cellules de la couleur choisie.
La fonction s'inscrit dans la cellule active, ses paramètres renseignés.
Tu peux aussi, bien sûr utiliser cette fonction depuis l'assistant fonction. La plage
à examiner est facile à sélectionner avec l'assistant, mais pour la couleur, il te
faudra prévoir une petite liste .
Public tabCouleurs, tabColors(1 To 41, 1 To 2)
Sub MainMenu()
'commande du menu contextuel des cellules
'exécuter une fois, ou mettre dans le Workbook_Open
'd'une macro complémentaire
Dim mCtrl As CommandBarPopup
Set mCtrl = Application.CommandBars("Cell"). _
Controls.Add(msoControlPopup, before:=1)
With mCtrl
.Caption = "Somme par couleur"
.OnAction = "AddCouleurs"
End With
End Sub
Private Sub AddCouleurs()
'ajoute à la commande du menu contextuel des cellules
'autant d'entrées qu'il y a de couleurs utilisées dans la feuille active
Dim mCtrl As CommandBarPopup, bCtrl As CommandBarButton
Set mCtrl = Application.CommandBars("Cell"). _
Controls("Somme par couleur")
For I = mCtrl.Controls.Count To 1 Step -1
mCtrl.Controls(I).Delete
Next
CouleursUtilisées
For I = LBound(tabCouleurs) To UBound(tabCouleurs)
With mCtrl.Controls.Add(msoControlButton)
.Caption = NomCouleur(tabCouleurs(I)) & " (" & tabCouleurs(I) & ")"
.FaceId = 2170
.OnAction = "'Compte """ & tabCouleurs(I) & """'"
End With
Next
'plus une pour détruire le menu si besoin
Set bCtrl = mCtrl.Controls.Add(msoControlButton)
With bCtrl
.Caption = "Détruire ce menu"
.FaceId = 3265
.BeginGroup = True
.OnAction = "DelMainMenu"
End With
End Sub
Sub Compte(IndexCouleur)
'procédure OnAction des commandes de chaque couleur
'la fonction de somme des cellules de la couleur choisie
'est inscrite dans la cellule active
Dim plage As Range, Msg$
Msg = "Sélectionnez la plage qui contient" & vbLf
Msg = Msg & "les cellules de couleur '" & _
NomCouleur(CLng(IndexCouleur)) & "'" & vbLf
Msg = Msg & "que vous voulez additionner :"
'choix de la plage qui contient les cellules à sommer
On Error Resume Next
Set plage = Application.InputBox(Msg, "Somme par couleur", , , , , , 8)
If plage Is Nothing Then Exit Sub
'la cellule active ne doit pas être dans la plage examinée
If Not Intersect(plage, ActiveCell) Is Nothing Then
Msg = "La cellule active fait partie de la plage à examiner." & vbLf
Msg = Msg & "Risque de référence circulaire. Abandon !"
MsgBox Msg, , "Somme par couleur"
Exit Sub
End If
'si la cellule active n'est pas libre
If Not IsEmpty(ActiveCell) Then
If MsgBox("La cellule active n'est pas vide. Continuer ?", vbYesNo, _
"Somme par couleur") = vbNo Then Exit Sub
End If
'renvoi de la formule dans la cellule active
ActiveCell.FormulaLocal = _
"=SommeSelonCouleur(" & plage.Address(0, 0) & ";" & CLng(IndexCouleur) & ")"
End Sub
'pour faire la somme des cellules *sans* couleur, passer -4142 pour Couleur
Function SommeSelonCouleur(Plage_à_examiner As Range, _
Couleur_à_sommer As Long) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = Plage_à_examiner
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If Plage_à_examiner(I, J).Interior.ColorIndex = _
Couleur_à_sommer Then
SommeSelonCouleur = SommeSelonCouleur + Arr(I, J)
End If
Next J
Next I
End Function
************************************
Private Sub DelMainMenu()
'détruit la commande principale du menu contextuel des cellules
'(à mettre éventuellement dans l'événement Workbook_AddinUninstall
'd'une macro complémentaire)
On Error Resume Next
Application.CommandBars("Cell"). _
Controls("Somme par couleur").Delete
End Sub
'*****Traitements des tableaux globaux*****
Private Function NomCouleur(Idx) As String
'renvoi le nom de la couleur dans la palette d'Excel à partir de l'index
InitNomsCouleurs
For I = 1 To 41
If tabColors(I, 1) = Idx Then
NomCouleur = tabColors(I, 2)
Exit Function
End If
Next
End Function
Private Sub CouleursUtilisées()
'remplit le tableau des couleurs utilisées dans la feuille active
'xlNone=-4142
Dim Vue As Boolean, I&, J&, cell As Range
Dim IdxCouleur&
I = 0
ReDim tabCouleurs(0)
For Each cell In ActiveSheet.UsedRange
If cell.Interior.ColorIndex <> -4142 Then
Vue = False
IdxCouleur = cell.Interior.ColorIndex
For J = LBound(tabCouleurs) To UBound(tabCouleurs)
If tabCouleurs(J) = IdxCouleur Then
Vue = True: Exit For
End If
Next
If Not Vue Then
tabCouleurs(I) = IdxCouleur
I = I + 1
ReDim Preserve tabCouleurs(I)
End If
End If
Next
tabCouleurs(I) = -4142
End Sub
Private Sub InitNomsCouleurs()
'remplit le tableau qui donne l'équivalence entre le ColorIndex
'et le nom de la couleur dans la palette d'Excel
tabColors(1, 1) = 1: tabColors(1, 2) = "Noir"
tabColors(2, 1) = 9: tabColors(2, 2) = "Rouge foncé"
tabColors(3, 1) = 3: tabColors(3, 2) = "Rouge"
tabColors(4, 1) = 7: tabColors(4, 2) = "Rose"
tabColors(5, 1) = 38: tabColors(5, 2) = "Rose saumon"
tabColors(6, 1) = 53: tabColors(6, 2) = "Marron"
tabColors(7, 1) = 46: tabColors(7, 2) = "Orange"
tabColors(8, 1) = 45: tabColors(8, 2) = "Orange clair"
tabColors(9, 1) = 44: tabColors(9, 2) = "Or"
tabColors(10, 1) = 40: tabColors(10, 2) = "Brun"
tabColors(11, 1) = 52: tabColors(11, 2) = "Vert olive"
tabColors(12, 1) = 12: tabColors(12, 2) = "Marron clair"
tabColors(13, 1) = 43: tabColors(13, 2) = "Citron vert"
tabColors(14, 1) = 6: tabColors(14, 2) = "Jaune"
tabColors(15, 1) = 36: tabColors(15, 2) = "Jaune clair"
tabColors(16, 1) = 51: tabColors(16, 2) = "Vert foncé"
tabColors(17, 1) = 10: tabColors(17, 2) = "Vert"
tabColors(18, 1) = 50: tabColors(18, 2) = "Vert marin"
tabColors(19, 1) = 4: tabColors(19, 2) = "Vert brillant"
tabColors(20, 1) = 35: tabColors(20, 2) = "Vert clair"
tabColors(21, 1) = 49: tabColors(21, 2) = "Bleu-vert foncé"
tabColors(22, 1) = 14: tabColors(22, 2) = "Bleu-vert"
tabColors(23, 1) = 42: tabColors(23, 2) = "Vert d'eau"
tabColors(24, 1) = 8: tabColors(24, 2) = "Turquoise"
tabColors(25, 1) = 34: tabColors(25, 2) = "Turquoise clair"
tabColors(26, 1) = 11: tabColors(26, 2) = "Bleu foncé"
tabColors(27, 1) = 5: tabColors(27, 2) = "Bleu"
tabColors(28, 1) = 41: tabColors(28, 2) = "Bleu clair"
tabColors(29, 1) = 33: tabColors(29, 2) = "Bleu ciel"
tabColors(30, 1) = 37: tabColors(30, 2) = "Bleu moyen"
tabColors(31, 1) = 55: tabColors(31, 2) = "Indigo"
tabColors(32, 1) = 47: tabColors(32, 2) = "Bleu-gris"
tabColors(33, 1) = 13: tabColors(33, 2) = "Violet"
tabColors(34, 1) = 54: tabColors(34, 2) = "Prune"
tabColors(35, 1) = 39: tabColors(35, 2) = "Lavande"
tabColors(36, 1) = 56: tabColors(36, 2) = "Gris-80%"
tabColors(37, 1) = 16: tabColors(37, 2) = "Gris-50%"
tabColors(38, 1) = 48: tabColors(38, 2) = "Gris-40%"
tabColors(39, 1) = 15: tabColors(39, 2) = "Gris-25%"
tabColors(40, 1) = 2: tabColors(40, 2) = "Blanc"
tabColors(41, 1) = -4142: tabColors(41, 2) = "(Aucune)"
End Sub
A vous de déméler le tien du sien !
MainMenu.
Dans Excel, là où tu as des cellules de couleur à additionner, sélectionne une
cellule puis clic droit. Choisis "Somme par couleur" puis la couleur qui
t'intéresse puis la plage qui contient les cellules de la couleur choisie.
La fonction s'inscrit dans la cellule active, ses paramètres renseignés.
Tu peux aussi, bien sûr utiliser cette fonction depuis l'assistant fonction. La plage
à examiner est facile à sélectionner avec l'assistant, mais pour la couleur, il te
faudra prévoir une petite liste .
Public tabCouleurs, tabColors(1 To 41, 1 To 2)
Sub MainMenu()
'commande du menu contextuel des cellules
'exécuter une fois, ou mettre dans le Workbook_Open
'd'une macro complémentaire
Dim mCtrl As CommandBarPopup
Set mCtrl = Application.CommandBars("Cell"). _
Controls.Add(msoControlPopup, before:=1)
With mCtrl
.Caption = "Somme par couleur"
.OnAction = "AddCouleurs"
End With
End Sub
Private Sub AddCouleurs()
'ajoute à la commande du menu contextuel des cellules
'autant d'entrées qu'il y a de couleurs utilisées dans la feuille active
Dim mCtrl As CommandBarPopup, bCtrl As CommandBarButton
Set mCtrl = Application.CommandBars("Cell"). _
Controls("Somme par couleur")
For I = mCtrl.Controls.Count To 1 Step -1
mCtrl.Controls(I).Delete
Next
CouleursUtilisées
For I = LBound(tabCouleurs) To UBound(tabCouleurs)
With mCtrl.Controls.Add(msoControlButton)
.Caption = NomCouleur(tabCouleurs(I)) & " (" & tabCouleurs(I) & ")"
.FaceId = 2170
.OnAction = "'Compte """ & tabCouleurs(I) & """'"
End With
Next
'plus une pour détruire le menu si besoin
Set bCtrl = mCtrl.Controls.Add(msoControlButton)
With bCtrl
.Caption = "Détruire ce menu"
.FaceId = 3265
.BeginGroup = True
.OnAction = "DelMainMenu"
End With
End Sub
Sub Compte(IndexCouleur)
'procédure OnAction des commandes de chaque couleur
'la fonction de somme des cellules de la couleur choisie
'est inscrite dans la cellule active
Dim plage As Range, Msg$
Msg = "Sélectionnez la plage qui contient" & vbLf
Msg = Msg & "les cellules de couleur '" & _
NomCouleur(CLng(IndexCouleur)) & "'" & vbLf
Msg = Msg & "que vous voulez additionner :"
'choix de la plage qui contient les cellules à sommer
On Error Resume Next
Set plage = Application.InputBox(Msg, "Somme par couleur", , , , , , 8)
If plage Is Nothing Then Exit Sub
'la cellule active ne doit pas être dans la plage examinée
If Not Intersect(plage, ActiveCell) Is Nothing Then
Msg = "La cellule active fait partie de la plage à examiner." & vbLf
Msg = Msg & "Risque de référence circulaire. Abandon !"
MsgBox Msg, , "Somme par couleur"
Exit Sub
End If
'si la cellule active n'est pas libre
If Not IsEmpty(ActiveCell) Then
If MsgBox("La cellule active n'est pas vide. Continuer ?", vbYesNo, _
"Somme par couleur") = vbNo Then Exit Sub
End If
'renvoi de la formule dans la cellule active
ActiveCell.FormulaLocal = _
"=SommeSelonCouleur(" & plage.Address(0, 0) & ";" & CLng(IndexCouleur) & ")"
End Sub
'pour faire la somme des cellules *sans* couleur, passer -4142 pour Couleur
Function SommeSelonCouleur(Plage_à_examiner As Range, _
Couleur_à_sommer As Long) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = Plage_à_examiner
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If Plage_à_examiner(I, J).Interior.ColorIndex = _
Couleur_à_sommer Then
SommeSelonCouleur = SommeSelonCouleur + Arr(I, J)
End If
Next J
Next I
End Function
************************************
Private Sub DelMainMenu()
'détruit la commande principale du menu contextuel des cellules
'(à mettre éventuellement dans l'événement Workbook_AddinUninstall
'd'une macro complémentaire)
On Error Resume Next
Application.CommandBars("Cell"). _
Controls("Somme par couleur").Delete
End Sub
'*****Traitements des tableaux globaux*****
Private Function NomCouleur(Idx) As String
'renvoi le nom de la couleur dans la palette d'Excel à partir de l'index
InitNomsCouleurs
For I = 1 To 41
If tabColors(I, 1) = Idx Then
NomCouleur = tabColors(I, 2)
Exit Function
End If
Next
End Function
Private Sub CouleursUtilisées()
'remplit le tableau des couleurs utilisées dans la feuille active
'xlNone=-4142
Dim Vue As Boolean, I&, J&, cell As Range
Dim IdxCouleur&
I = 0
ReDim tabCouleurs(0)
For Each cell In ActiveSheet.UsedRange
If cell.Interior.ColorIndex <> -4142 Then
Vue = False
IdxCouleur = cell.Interior.ColorIndex
For J = LBound(tabCouleurs) To UBound(tabCouleurs)
If tabCouleurs(J) = IdxCouleur Then
Vue = True: Exit For
End If
Next
If Not Vue Then
tabCouleurs(I) = IdxCouleur
I = I + 1
ReDim Preserve tabCouleurs(I)
End If
End If
Next
tabCouleurs(I) = -4142
End Sub
Private Sub InitNomsCouleurs()
'remplit le tableau qui donne l'équivalence entre le ColorIndex
'et le nom de la couleur dans la palette d'Excel
tabColors(1, 1) = 1: tabColors(1, 2) = "Noir"
tabColors(2, 1) = 9: tabColors(2, 2) = "Rouge foncé"
tabColors(3, 1) = 3: tabColors(3, 2) = "Rouge"
tabColors(4, 1) = 7: tabColors(4, 2) = "Rose"
tabColors(5, 1) = 38: tabColors(5, 2) = "Rose saumon"
tabColors(6, 1) = 53: tabColors(6, 2) = "Marron"
tabColors(7, 1) = 46: tabColors(7, 2) = "Orange"
tabColors(8, 1) = 45: tabColors(8, 2) = "Orange clair"
tabColors(9, 1) = 44: tabColors(9, 2) = "Or"
tabColors(10, 1) = 40: tabColors(10, 2) = "Brun"
tabColors(11, 1) = 52: tabColors(11, 2) = "Vert olive"
tabColors(12, 1) = 12: tabColors(12, 2) = "Marron clair"
tabColors(13, 1) = 43: tabColors(13, 2) = "Citron vert"
tabColors(14, 1) = 6: tabColors(14, 2) = "Jaune"
tabColors(15, 1) = 36: tabColors(15, 2) = "Jaune clair"
tabColors(16, 1) = 51: tabColors(16, 2) = "Vert foncé"
tabColors(17, 1) = 10: tabColors(17, 2) = "Vert"
tabColors(18, 1) = 50: tabColors(18, 2) = "Vert marin"
tabColors(19, 1) = 4: tabColors(19, 2) = "Vert brillant"
tabColors(20, 1) = 35: tabColors(20, 2) = "Vert clair"
tabColors(21, 1) = 49: tabColors(21, 2) = "Bleu-vert foncé"
tabColors(22, 1) = 14: tabColors(22, 2) = "Bleu-vert"
tabColors(23, 1) = 42: tabColors(23, 2) = "Vert d'eau"
tabColors(24, 1) = 8: tabColors(24, 2) = "Turquoise"
tabColors(25, 1) = 34: tabColors(25, 2) = "Turquoise clair"
tabColors(26, 1) = 11: tabColors(26, 2) = "Bleu foncé"
tabColors(27, 1) = 5: tabColors(27, 2) = "Bleu"
tabColors(28, 1) = 41: tabColors(28, 2) = "Bleu clair"
tabColors(29, 1) = 33: tabColors(29, 2) = "Bleu ciel"
tabColors(30, 1) = 37: tabColors(30, 2) = "Bleu moyen"
tabColors(31, 1) = 55: tabColors(31, 2) = "Indigo"
tabColors(32, 1) = 47: tabColors(32, 2) = "Bleu-gris"
tabColors(33, 1) = 13: tabColors(33, 2) = "Violet"
tabColors(34, 1) = 54: tabColors(34, 2) = "Prune"
tabColors(35, 1) = 39: tabColors(35, 2) = "Lavande"
tabColors(36, 1) = 56: tabColors(36, 2) = "Gris-80%"
tabColors(37, 1) = 16: tabColors(37, 2) = "Gris-50%"
tabColors(38, 1) = 48: tabColors(38, 2) = "Gris-40%"
tabColors(39, 1) = 15: tabColors(39, 2) = "Gris-25%"
tabColors(40, 1) = 2: tabColors(40, 2) = "Blanc"
tabColors(41, 1) = -4142: tabColors(41, 2) = "(Aucune)"
End Sub
A vous de déméler le tien du sien !
Frédéric Sigonneau, Laurent Longre, (N°763)