Je ne parviens pas à utiliser .find dans une focntion perso. C'est normal ?
On ne peut invoquer .Find dans une fonction perso appelée de la feuille excel qu'avec excel 2003.
Function TrouverMot(PlageDeRecherche As Range, mot As String)
Set zz = Range(PlageDeRecherche.Find(what:="" & mot).Address)
If Not zz Is Nothing Then
TrouverMot = zz.Address
Else
TrouverMot = "Introuvable"
End If
End Function
Function TrouverMot(PlageDeRecherche As Range, mot As String)
Set zz = Range(PlageDeRecherche.Find(what:="" & mot).Address)
If Not zz Is Nothing Then
TrouverMot = zz.Address
Else
TrouverMot = "Introuvable"
End If
End Function
Isabelle, Polemos,
Ajouté ou modifié le 02/06/2004 (N°1441)
Ajouté ou modifié le 02/06/2004 (N°1441)
J'ultilise la fonction alea.entre.bornes. Pourquoi retourne-t-elle 2 valeurs
différentes
si on
l'encode dans 2 cellules différentes et change-t-elle de valeur à chaque fois
qu'on modifie n'importe quelle cellule de la feuille ?
C'est tout simplement parce que c'est une des fonctions volatiles innées à Excel.
comme : Maintenant(), aujourdhui(), zones(), Index(), decaler(),
cellule(), Indirect(), lignes(), colonnes(), Alea()
Ces fonctions sont réévaluées à chaque recalcul de la feuille d'excel.
comme : Maintenant(), aujourdhui(), zones(), Index(), decaler(),
cellule(), Indirect(), lignes(), colonnes(), Alea()
Ces fonctions sont réévaluées à chaque recalcul de la feuille d'excel.
Denis Michon,
Ajouté ou modifié le 02/06/2004 (N°1439)
Ajouté ou modifié le 02/06/2004 (N°1439)
J'ai une simple formule dans un classeur excel sous PC qui fonctionne très bien
=SOMME(A1:A20). Quand je la copie pour la coller dans un excel pour mac, cela ne
fonctionne plus !
Ce n'est (heureusement !) pas un problème de compatibilité des formules entre mac et pc.
En faisant des copier/coller d'un environnement à un autre (via le web ou le mail notamment), il est
possible que des caractères parasites se promènent.
Ceci est particulièrement visible quand on utilise non plus des fonctions de la feuille de calcul
mais des macros. Le copier/coller se traduit parfois par la mise en rouge de lignes pourtant
apparemment correctes. L'effacement de tous les caractères de début de ligne, quitte à remettre
ensuite des tabulations pour la présentation, permet souvent de rétablir la situation.
En faisant des copier/coller d'un environnement à un autre (via le web ou le mail notamment), il est
possible que des caractères parasites se promènent.
Ceci est particulièrement visible quand on utilise non plus des fonctions de la feuille de calcul
mais des macros. Le copier/coller se traduit parfois par la mise en rouge de lignes pourtant
apparemment correctes. L'effacement de tous les caractères de début de ligne, quitte à remettre
ensuite des tabulations pour la présentation, permet souvent de rétablir la situation.
Bernard Rey,
Ajouté ou modifié le 02/06/2004 (N°1437)
Ajouté ou modifié le 02/06/2004 (N°1437)
Je voudrais faire appel depuis le classeurA à une fonction contenue dans un classeurB.
En VBA :
Toto = Run("'Classeur B.xls'!MaFonction", Param1, Param2)
Ou alors ajouter une référence vers Classeur B et appeler la fonction
directement comme si elle était dans Classeur A :
(les deux classeurs doivent être ouverts).
Pour ça il faut d'abord renommer le VBAProject du classeurB (clic droit sur son
projet dans l'éditeur puis Propriétés de VBAProject puis donne le nom de ton
choix dans la zone Nom du projet, par ex ProjetB). Ensuite, sélectionne le
VBAProject du classeurA en cliquant dessus puis par le menu Outils\Références
coche ProjetB dans la liste et OK. Un dossier Références s'ajoute au VBAProjet
du classeurA, avec une liaison vers le classeurB. A partir de là tu peux
utiliser directement dans le code du classeurA les procédures et fonctions
publiques du classeurB.
Supposons une fonction dans un module standard du classeurB :
Function bidon(rez)
bidon = rez & " : " & rez
End Function
Après établisement d'une référence vers B, tu peux écrire dans un module
standard du classeur A :
Sub test()
MsgBox bidon(25)
End Sub
ou dans une feuille de calcul du classeur A :
=bidon(25)
Toto = Run("'Classeur B.xls'!MaFonction", Param1, Param2)
Ou alors ajouter une référence vers Classeur B et appeler la fonction
directement comme si elle était dans Classeur A :
(les deux classeurs doivent être ouverts).
Pour ça il faut d'abord renommer le VBAProject du classeurB (clic droit sur son
projet dans l'éditeur puis Propriétés de VBAProject puis donne le nom de ton
choix dans la zone Nom du projet, par ex ProjetB). Ensuite, sélectionne le
VBAProject du classeurA en cliquant dessus puis par le menu Outils\Références
coche ProjetB dans la liste et OK. Un dossier Références s'ajoute au VBAProjet
du classeurA, avec une liaison vers le classeurB. A partir de là tu peux
utiliser directement dans le code du classeurA les procédures et fonctions
publiques du classeurB.
Supposons une fonction dans un module standard du classeurB :
Function bidon(rez)
bidon = rez & " : " & rez
End Function
Après établisement d'une référence vers B, tu peux écrire dans un module
standard du classeur A :
Sub test()
MsgBox bidon(25)
End Sub
ou dans une feuille de calcul du classeur A :
=bidon(25)
Laurent Longre, Frédéric Sigonneau,
Ajouté ou modifié le 16/05/2004 (N°1407)
Ajouté ou modifié le 16/05/2004 (N°1407)
J'ai créé une fonction qui permet de déterminer le code couleur de fond d'une cellule. Celle-ci
fonctionne bien, malheureusement, lorsque je change cette couleur, il faut que je revalide la
formule pour qu'elle se réactualise. Comment faire pour qu'elle se recalcule automatiquement ?
Met Application.volatile au début de la fonction
Iznogood, (N°755)
Dans mes macros j'ai souvent besoin de ligne du genre
If variable= A ou variable = B ou variable = C.... then
Pour simplifier, y a-t-il moyen d'écrire quelque chose style
valeurs = A ou B ou C pour ensuite pouvoir écrire If variable=valeurs then..?
Sub VariablesORed()
'leo.heuser@get2net.dk, August 15, 2001
Dim MyValue As Variant
Dim MyVariable
MyValue = Array(2, 348.34, 4, 5)
MyVariable = 3
If Check(MyVariable, MyValue) Then
MsgBox "Bingo!"
Else
MsgBox "raté!"
End If
On Error GoTo 0
End Sub
Function Check(MyVariable, MyArray) As Boolean
Dim Element
Check = False
For Each Element In MyArray
If MyVariable = Element Then
Check = True
Exit For
End If
Next Element
End Function
***************
Autre possibilité qui n'utilise pas de boucle (donc normalement plus rapide).
Function CheckVar(LaVariable, LeTableau) As Boolean
CheckVar = Not IsError(Application.Match(LaVariable, LeTableau, 0))
End Function
Tu peux lui passer aussi bien une valeur "en dur" et un tableau, que des
cellules/plages :
Sub test()
Arr = Array("Var1", "Var2", "Var3", "Var4")
MsgBox CheckVar("Var3", Arr)
'ou :
Range("A1:A30").Value = "test": Range("D1").Value = "retest"
MsgBox CheckVar(Range("d1").Value, Range("A1:A30"))
End Sub
'leo.heuser@get2net.dk, August 15, 2001
Dim MyValue As Variant
Dim MyVariable
MyValue = Array(2, 348.34, 4, 5)
MyVariable = 3
If Check(MyVariable, MyValue) Then
MsgBox "Bingo!"
Else
MsgBox "raté!"
End If
On Error GoTo 0
End Sub
Function Check(MyVariable, MyArray) As Boolean
Dim Element
Check = False
For Each Element In MyArray
If MyVariable = Element Then
Check = True
Exit For
End If
Next Element
End Function
***************
Autre possibilité qui n'utilise pas de boucle (donc normalement plus rapide).
Function CheckVar(LaVariable, LeTableau) As Boolean
CheckVar = Not IsError(Application.Match(LaVariable, LeTableau, 0))
End Function
Tu peux lui passer aussi bien une valeur "en dur" et un tableau, que des
cellules/plages :
Sub test()
Arr = Array("Var1", "Var2", "Var3", "Var4")
MsgBox CheckVar("Var3", Arr)
'ou :
Range("A1:A30").Value = "test": Range("D1").Value = "retest"
MsgBox CheckVar(Range("d1").Value, Range("A1:A30"))
End Sub
Leo Heuser, Frédéric Sigonneau, (N°753)
Comment créer une fonction pour compter en nombres troll ?
la véritable fonction
NbTroll() à utiliser sous la forme =NbTroll(A1) ou =NbTroll(26)
Function NbTroll(Cellule As Variant)
Dim Rep, Rep1, Texte As String, Test
Rep = Int(Cellule / 64)
If Rep > 3 Then
Texte = "Trop...Grr !"
Test = Evaluate("=rand()")
If Test > 0.5 Then Texte = Texte & "...Arggh!..."
GoTo Suite
End If
Texte = Evaluate("=rept(""Des Flopées ""," & Rep & ")")
Rep1 = Cellule Mod 64
Rep = Int(Rep1 / 16)
Texte = Texte & Evaluate("=rept(""Des Tas ""," & Rep & ")")
Rep1 = Rep1 Mod 16
Rep = Int(Rep1 / 4)
Texte = Texte & Evaluate("=rept(""Beaucoup ""," & Rep & ")")
Rep1 = Rep1 Mod 4
Select Case Rep1
Case 0
Rep1 = ""
Case 1
Rep1 = "Un"
Case 2
Rep1 = "Deux"
Case 3
Rep1 = "Trois"
Case Else
Texte = "Grr"
End Select
Texte = Texte & Rep1
Suite:
NbTroll = Texte
End Function
je tiens toutefois à préciser afin d'éviter d'eventuels accidents ou autres
incompréhensions qui se solderaient par le décès du questionneur que les
Trolls dont il s'agit, n'ont rien à voir avec les terres du Milieu, mais
bien plutôt avec le disque-monde (vous trouverez le guide de voyage dans
toutes les bonnes librairies).
En raison de la nature siliceuse de leur cerveau, leurs réactions au calcul
minéral dépend de la température extérieure, à plus de 50 degrés, ils
n'iront que rarement au-delà de "beaucoup", entre 20° et 50°, ils peuvent
concevoir "des tas", l'appréhension du "Des flopées" ne devrait intervenir
qu'à partir de 0°. Si l'un d'entre vous pouvait amener un troll dans une
chambre froide négative, je pense que nous pourrions améliorer encore cette
macro (il est préférable pour la réussite de l'opération d'emmener un
magnétophone afin que cette conversation ne soit pas perdue en cas de décès
accidentel toujours possible)
En vous remerciant par avance !
Tout cela parce que des gens mal intentionnés on dit que les trolls ne
savaient pas compter au delà de 3, un deux, trois, des Tas. Cette petite
procédure vous montre que le système est un peu compliqué. J'ai
personnellement trouvé gravé sur un dolmen à peine goûté, la traduction de
64 qui pourrait s'appeller "des Flopées". j'ai encore un doute sur 256,
comme cela se traduit-il ? ceux qui habitent près d'une montagne
pourraient-ils se renseigner ?
Ne vous méprenez pas sur ma démarche, elle vise à améliorer les relations
entre les peuples, Trolls, injustement méprisés jusqu'à aujourd'hui, inclus.
Vous verrez qu'ainsi, il vaut mieux des flopées de pas entre vous et un
troll que beaucoup de pas !
NbTroll() à utiliser sous la forme =NbTroll(A1) ou =NbTroll(26)
Function NbTroll(Cellule As Variant)
Dim Rep, Rep1, Texte As String, Test
Rep = Int(Cellule / 64)
If Rep > 3 Then
Texte = "Trop...Grr !"
Test = Evaluate("=rand()")
If Test > 0.5 Then Texte = Texte & "...Arggh!..."
GoTo Suite
End If
Texte = Evaluate("=rept(""Des Flopées ""," & Rep & ")")
Rep1 = Cellule Mod 64
Rep = Int(Rep1 / 16)
Texte = Texte & Evaluate("=rept(""Des Tas ""," & Rep & ")")
Rep1 = Rep1 Mod 16
Rep = Int(Rep1 / 4)
Texte = Texte & Evaluate("=rept(""Beaucoup ""," & Rep & ")")
Rep1 = Rep1 Mod 4
Select Case Rep1
Case 0
Rep1 = ""
Case 1
Rep1 = "Un"
Case 2
Rep1 = "Deux"
Case 3
Rep1 = "Trois"
Case Else
Texte = "Grr"
End Select
Texte = Texte & Rep1
Suite:
NbTroll = Texte
End Function
je tiens toutefois à préciser afin d'éviter d'eventuels accidents ou autres
incompréhensions qui se solderaient par le décès du questionneur que les
Trolls dont il s'agit, n'ont rien à voir avec les terres du Milieu, mais
bien plutôt avec le disque-monde (vous trouverez le guide de voyage dans
toutes les bonnes librairies).
En raison de la nature siliceuse de leur cerveau, leurs réactions au calcul
minéral dépend de la température extérieure, à plus de 50 degrés, ils
n'iront que rarement au-delà de "beaucoup", entre 20° et 50°, ils peuvent
concevoir "des tas", l'appréhension du "Des flopées" ne devrait intervenir
qu'à partir de 0°. Si l'un d'entre vous pouvait amener un troll dans une
chambre froide négative, je pense que nous pourrions améliorer encore cette
macro (il est préférable pour la réussite de l'opération d'emmener un
magnétophone afin que cette conversation ne soit pas perdue en cas de décès
accidentel toujours possible)
En vous remerciant par avance !
Tout cela parce que des gens mal intentionnés on dit que les trolls ne
savaient pas compter au delà de 3, un deux, trois, des Tas. Cette petite
procédure vous montre que le système est un peu compliqué. J'ai
personnellement trouvé gravé sur un dolmen à peine goûté, la traduction de
64 qui pourrait s'appeller "des Flopées". j'ai encore un doute sur 256,
comme cela se traduit-il ? ceux qui habitent près d'une montagne
pourraient-ils se renseigner ?
Ne vous méprenez pas sur ma démarche, elle vise à améliorer les relations
entre les peuples, Trolls, injustement méprisés jusqu'à aujourd'hui, inclus.
Vous verrez qu'ainsi, il vaut mieux des flopées de pas entre vous et un
troll que beaucoup de pas !
Thierry Rural, (N°752)
Je voudrais une fonction qui ne fasse la somme que des cellules visibles.
Une fonction perso ?
Function S_masq(plg As Range)
Application.Volatile
For Each x In plg
If x.EntireRow.Hidden = True Then
Else: S = S + x.Value
End If
Next
S_masq = S
End Function
Problème : le masquage d'une ligne ne déclenchera pas la mise à jour de la
formule
Alors, peut-être, ajouter dans le module de la feuille :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Calculate
End Sub
Function S_masq(plg As Range)
Application.Volatile
For Each x In plg
If x.EntireRow.Hidden = True Then
Else: S = S + x.Value
End If
Next
S_masq = S
End Function
Problème : le masquage d'une ligne ne déclenchera pas la mise à jour de la
formule
Alors, peut-être, ajouter dans le module de la feuille :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Calculate
End Sub
Alain vallon, (N°751)
Comment écrit-on si a=1 ou 2 ou 5 ou 154 sur la feuille excel ou en VBA...?
* Dans la feuille de calcul :
=SI(OU(A1=1;A1=2;A1=5;A1=154);"Valeur trouvée";"Valeur non trouvée")
* En vba
MsgBox [if(or(a1=1,a1=2,a1=5,a1=154),"valeur trouvée","valeur non trouvée")]
ou
MsgBox [IF(OR(A1={1;2;5;154}),"Valeur trouvée","Valeur non trouvée")]
=SI(OU(A1=1;A1=2;A1=5;A1=154);"Valeur trouvée";"Valeur non trouvée")
* En vba
MsgBox [if(or(a1=1,a1=2,a1=5,a1=154),"valeur trouvée","valeur non trouvée")]
ou
MsgBox [IF(OR(A1={1;2;5;154}),"Valeur trouvée","Valeur non trouvée")]
Alain Vallon, Daniel Maher,
Ajouté ou modifié le 25/10/2003 (N°750)
Ajouté ou modifié le 25/10/2003 (N°750)
Je cherche une fonction qui m'écrive les nombres comme les romains mais qui aille au delà des
3999 prévus par excel.
la fonction ROMAIN() transforme effectivement les nombres en chiffres romains
jusqu'à 3999.
Il paraîtrait que les romains n'avaient pas été plus loin dans leur méthode,
ce qui fait qu'au delà de 3999, il n'y a pas d'autre nombre que les M pour
les milliers.
10 152 s'écrirait ainsi MMMMMMMMMMCLII.
Voici donc une fonction que j'ai nommée
NBRE_ROMAIN() qui, elle, va au maximum possible des
milliers. Elle ne parle pas de millions, nombre non prévu par les romains.
De même, elle compte en nombres romains inventés au moyen âge sur le
principe de 4=IV au lieu de 4 =IIII comme faisaient les romains (ils étaient
fadas ceux là:-))
De même 900 = CM et non DCCCC
=NBRE_ROMAIN(E6;2) donnera la valeur DCCCC
=NBRE_ROMAIN(E6;1) donnera la valeur CM
J'ai utilisé la méthode que voici:
Pour les milliers, j'ai divisé le nombre par 1000 et pris l'entier
Pour les centaines j'ai pris le nombre moins les milliers et divisé l'entier
par 100
Pour les dizaines Le nombre - les milliers et les centaines divisé par 10
puis le reste.
***************************************
Function NBRE_ROMAIN(NBR As Integer, Vers As Integer)
'pour les milliers
MR = Int(NBR / 1000)
If MR > 0 Then
For I = 1 To MR
TMR = TMR & "M"
Next
End If
'pour les centaines
CR = Int((NBR - (MR * 1000)) / 100)
If Vers = 1 And CR >= 9 Then
TCR = "CM"
End If
If Vers <> 1 And CR >= 9 Then
TCR = "DCCCC"
End If
If CR >= 5 And CR < 9 Then
For K = 6 To CR
C = "C" & C
Next
TCR = "D" & C
End If
If CR >= 4 And CR < 5 Then
TCR = "CD"
End If
If CR > 0 And CR < 4 Then
For J = 1 To CR
TCR = TCR & "C"
Next
End If
'pour Les dizaines
DR = Int((NBR - ((MR * 1000) + (CR * 100))) / 10)
If DR >= 9 Then
TDR = "XC"
End If
If DR >= 5 And DR < 9 Then
For L = 6 To DR
d = d & "X"
Next
TDR = "L" & d
End If
If DR >= 4 And DR < 5 Then
TDR = "XL"
End If
If DR < 4 Then
For L = 1 To DR
TDR = TDR & "X"
Next
End If
'pour les unités
UR = NBR - ((MR * 1000) + (CR * 100) + (DR * 10))
If Vers = 1 And UR >= 9 Then
TUR = "IX"
End If
If Vers <> 1 And UR >= 9 Then
TUR = "VIIII"
End If
If UR >= 5 And UR < 9 Then
For L = 6 To UR
U = U & "I"
Next
TUR = "V" & U
End If
If UR >= 4 And UR < 5 Then
TUR = "IV"
End If
If UR < 4 Then
For U = 1 To UR
TUR = TUR & "I"
Next
End If
NBRE_ROMAIN = TMR & TCR & TDR & TUR
End Function
jusqu'à 3999.
Il paraîtrait que les romains n'avaient pas été plus loin dans leur méthode,
ce qui fait qu'au delà de 3999, il n'y a pas d'autre nombre que les M pour
les milliers.
10 152 s'écrirait ainsi MMMMMMMMMMCLII.
Voici donc une fonction que j'ai nommée
NBRE_ROMAIN() qui, elle, va au maximum possible des
milliers. Elle ne parle pas de millions, nombre non prévu par les romains.
De même, elle compte en nombres romains inventés au moyen âge sur le
principe de 4=IV au lieu de 4 =IIII comme faisaient les romains (ils étaient
fadas ceux là:-))
De même 900 = CM et non DCCCC
=NBRE_ROMAIN(E6;2) donnera la valeur DCCCC
=NBRE_ROMAIN(E6;1) donnera la valeur CM
J'ai utilisé la méthode que voici:
Pour les milliers, j'ai divisé le nombre par 1000 et pris l'entier
Pour les centaines j'ai pris le nombre moins les milliers et divisé l'entier
par 100
Pour les dizaines Le nombre - les milliers et les centaines divisé par 10
puis le reste.
***************************************
Function NBRE_ROMAIN(NBR As Integer, Vers As Integer)
'pour les milliers
MR = Int(NBR / 1000)
If MR > 0 Then
For I = 1 To MR
TMR = TMR & "M"
Next
End If
'pour les centaines
CR = Int((NBR - (MR * 1000)) / 100)
If Vers = 1 And CR >= 9 Then
TCR = "CM"
End If
If Vers <> 1 And CR >= 9 Then
TCR = "DCCCC"
End If
If CR >= 5 And CR < 9 Then
For K = 6 To CR
C = "C" & C
Next
TCR = "D" & C
End If
If CR >= 4 And CR < 5 Then
TCR = "CD"
End If
If CR > 0 And CR < 4 Then
For J = 1 To CR
TCR = TCR & "C"
Next
End If
'pour Les dizaines
DR = Int((NBR - ((MR * 1000) + (CR * 100))) / 10)
If DR >= 9 Then
TDR = "XC"
End If
If DR >= 5 And DR < 9 Then
For L = 6 To DR
d = d & "X"
Next
TDR = "L" & d
End If
If DR >= 4 And DR < 5 Then
TDR = "XL"
End If
If DR < 4 Then
For L = 1 To DR
TDR = TDR & "X"
Next
End If
'pour les unités
UR = NBR - ((MR * 1000) + (CR * 100) + (DR * 10))
If Vers = 1 And UR >= 9 Then
TUR = "IX"
End If
If Vers <> 1 And UR >= 9 Then
TUR = "VIIII"
End If
If UR >= 5 And UR < 9 Then
For L = 6 To UR
U = U & "I"
Next
TUR = "V" & U
End If
If UR >= 4 And UR < 5 Then
TUR = "IV"
End If
If UR < 4 Then
For U = 1 To UR
TUR = TUR & "I"
Next
End If
NBRE_ROMAIN = TMR & TCR & TDR & TUR
End Function
Laurent Daures, (N°749)
J'essaie de trouver le minimum d'un groupe de 32 cellules non contigues. La fonction MIN suivie
des références des 32 cellules me donne un message d'erreur, vu le nombre trop élevé de
cellules.
Sélectionne toutes les cellules concernées (clic gauche en
maintenant la touche CTRL enfoncée) puis définis un nom
(insertion - nom - définir)
pour avoir le mini : = min(nom_de_ta_zone)
***************
Un truc simple pour utiliser plus de 30 arguments sans grande manip:
mets les 30 premiers entre parenthèses.
=MIN((Cell1;Cell2;...;Cell29;Cell30);Cell31;Cell32;...)
En mettant tous les groupes de 30 arguments (références de plages) entre
parenthèses, chacun de ces groupes est considéré comme un seul argument
(union de plages).
(et comme tu peux aussi diviser chaque groupe de 30 en autant d'union de
plages plus petites, le nombre d'arguments possibles est virtuellement
astronomique... ;-)
maintenant la touche CTRL enfoncée) puis définis un nom
(insertion - nom - définir)
pour avoir le mini : = min(nom_de_ta_zone)
***************
Un truc simple pour utiliser plus de 30 arguments sans grande manip:
mets les 30 premiers entre parenthèses.
=MIN((Cell1;Cell2;...;Cell29;Cell30);Cell31;Cell32;...)
En mettant tous les groupes de 30 arguments (références de plages) entre
parenthèses, chacun de ces groupes est considéré comme un seul argument
(union de plages).
(et comme tu peux aussi diviser chaque groupe de 30 en autant d'union de
plages plus petites, le nombre d'arguments possibles est virtuellement
astronomique... ;-)
François-Xavier Manceaux, Laurent Longre, (N°748)
Comment créer un groupe de fonctions personnelles ?
Attribute VB_Name = "CreerGroupeFonctionsPersos"
Créer un nouveau groupe de fonctions par macro à l'ouverture
d'un classeur ou d'une macro complémentaire:
(Laurent Longre, mpfe)
Lire les commentaires en fin de module
=============================================
Dans un module standard (fonctions de test) :
=============================================
Function HYPOTENUSE(Cote1 As Double, Cote2 As Double)
HYPOTENUSE = Sqr(Cote1 ^ 2 + Cote2 ^ 2)
End Function
Function MOYPOND(Valeurs, Coeffs) As Double
With Application
MOYPOND = .SumProduct(Valeurs, Coeffs) _
/ .SumIf(Valeurs, "<>", Coeffs)
End With
End Function
=============================
Dans le module ThisWorkbook :
=============================
Private Const NomCat As String = "Nouvelles fonctions"
Option Base 1
Private Sub Workbook_Open()
Dim I As Integer, LCat As Integer
Dim Cat As String
Dim NomFct, DescFct
Dim Addin As Boolean, FMasquée As Boolean
On Error GoTo Fin
Application.EnableCancelKey = xlErrorHandler
NomFct = Array("HYPOTENUSE", "MOYPOND")
DescFct = Array("Calcule la longueur de l'hypoténuse", _
"Calcule une moyenne pondérée")
Addin = Me.IsAddin
If Addin Then
Application.ScreenUpdating = False
Me.IsAddin = False
End If
FMasquée = Not Me.Windows(1).Visible
If FMasquée Then
Application.ScreenUpdating = False
Me.Windows(1).Visible = True
End If
LCat = 14
Do
LCat = LCat + 1
Application.ExecuteExcel4Macro _
"DEFINE.NAME(""Djzh" & LCat & """,0,2,,," & LCat & ")"
Cat = Names("Djzh" & LCat).Category
Loop While Cat <> "User Defined" And Cat <> NomCat
If Cat = "User Defined" Then _
Application.ExecuteExcel4Macro _
"DEFINE.NAME(""Djzh" & LCat & """,0,2,,,""" & NomCat & """)"
For I = 1 To UBound(NomFct)
Application.MacroOptions Macro:=NomFct(I), _
Description:=DescFct(I), Category:=LCat
Next I
For I = 15 To LCat
Application.ExecuteExcel4Macro "DELETE.NAME(""Djzh" & I & """)"
Next I
Fin:
If Addin Then Me.IsAddin = True
If FMasquée Then Me.Windows(1).Visible = False
ThisWorkbook.Saved = True
End Sub
=============================
Commentaires
HYPOTENUSE et MOYPOND sont placées dans le nouveau groupe "Nouvelles
Fonctions ", automatiquement détruit à la fermeture du classeur. Pour"
changer le nom de cette catégorie, les noms des fonctions à inclure et
leur description, il faut modifier respectivement le contenu des
constantes et variables NomCat, NomFct et DescFct.
Cette méthode fonctionne dans les macros complémentaires XLA et dans le
classeur Perso.xls sous Excel 97 et 2000 (avec les versions antérieures,
je ne sais pas). Elle ne marche pas bien quand l'Utilitaire d'Analyse
est chargé, à cause d'une anomalie (très énervante) dans la manière dont
cet utilitaire gère les catégories de fonctions.
l'exemple ci-dessus est dans une macro
Fonctions.xla à télécharger sur
http://longre.free.fr/downloads/Fonctions.zip
Cette macro doit être
chargée par Outils -> Macros complémentaires.
Créer un nouveau groupe de fonctions par macro à l'ouverture
d'un classeur ou d'une macro complémentaire:
(Laurent Longre, mpfe)
Lire les commentaires en fin de module
=============================================
Dans un module standard (fonctions de test) :
=============================================
Function HYPOTENUSE(Cote1 As Double, Cote2 As Double)
HYPOTENUSE = Sqr(Cote1 ^ 2 + Cote2 ^ 2)
End Function
Function MOYPOND(Valeurs, Coeffs) As Double
With Application
MOYPOND = .SumProduct(Valeurs, Coeffs) _
/ .SumIf(Valeurs, "<>", Coeffs)
End With
End Function
=============================
Dans le module ThisWorkbook :
=============================
Private Const NomCat As String = "Nouvelles fonctions"
Option Base 1
Private Sub Workbook_Open()
Dim I As Integer, LCat As Integer
Dim Cat As String
Dim NomFct, DescFct
Dim Addin As Boolean, FMasquée As Boolean
On Error GoTo Fin
Application.EnableCancelKey = xlErrorHandler
NomFct = Array("HYPOTENUSE", "MOYPOND")
DescFct = Array("Calcule la longueur de l'hypoténuse", _
"Calcule une moyenne pondérée")
Addin = Me.IsAddin
If Addin Then
Application.ScreenUpdating = False
Me.IsAddin = False
End If
FMasquée = Not Me.Windows(1).Visible
If FMasquée Then
Application.ScreenUpdating = False
Me.Windows(1).Visible = True
End If
LCat = 14
Do
LCat = LCat + 1
Application.ExecuteExcel4Macro _
"DEFINE.NAME(""Djzh" & LCat & """,0,2,,," & LCat & ")"
Cat = Names("Djzh" & LCat).Category
Loop While Cat <> "User Defined" And Cat <> NomCat
If Cat = "User Defined" Then _
Application.ExecuteExcel4Macro _
"DEFINE.NAME(""Djzh" & LCat & """,0,2,,,""" & NomCat & """)"
For I = 1 To UBound(NomFct)
Application.MacroOptions Macro:=NomFct(I), _
Description:=DescFct(I), Category:=LCat
Next I
For I = 15 To LCat
Application.ExecuteExcel4Macro "DELETE.NAME(""Djzh" & I & """)"
Next I
Fin:
If Addin Then Me.IsAddin = True
If FMasquée Then Me.Windows(1).Visible = False
ThisWorkbook.Saved = True
End Sub
=============================
Commentaires
HYPOTENUSE et MOYPOND sont placées dans le nouveau groupe "Nouvelles
Fonctions ", automatiquement détruit à la fermeture du classeur. Pour"
changer le nom de cette catégorie, les noms des fonctions à inclure et
leur description, il faut modifier respectivement le contenu des
constantes et variables NomCat, NomFct et DescFct.
Cette méthode fonctionne dans les macros complémentaires XLA et dans le
classeur Perso.xls sous Excel 97 et 2000 (avec les versions antérieures,
je ne sais pas). Elle ne marche pas bien quand l'Utilitaire d'Analyse
est chargé, à cause d'une anomalie (très énervante) dans la manière dont
cet utilitaire gère les catégories de fonctions.
l'exemple ci-dessus est dans une macro
Fonctions.xla à télécharger sur
http://longre.free.fr/downloads/Fonctions.zip
Cette macro doit être
chargée par Outils -> Macros complémentaires.
Laurent Longre, (N°747)
Comment utiliser une fonction écrite dans un module du perso.xls ?
Tu peux utiliser une fonction écrite dans un module du Perso.xls dans une
feuille de calcul mais il faut, contrairement à une fonction d'une macro
complémentaire, la faire précéder du nom du classeur. par exemple :
=PERSO.XLS!Tva1()
feuille de calcul mais il faut, contrairement à une fonction d'une macro
complémentaire, la faire précéder du nom du classeur. par exemple :
=PERSO.XLS!Tva1()
Frédéric Sigonneau, (N°746)
J'ai créé une fonction personnalisée mais je n'arrive pas à y accéder depuis mes classeurs.
Recopie la fonction dans un module standard du classeur où tu veux l'utiliser.
Ou, si tu veux pouvoir l'utiliser dans n'importe quel classeur, dans un module
standard du perso.xls.
Inconvénient, pour l'utiliser il faudra la "qualifier" :
=perso.xls!AdrHyperlien(A1)
Remède possible : mettre la propriété IsAddin du perso.xls à True, ensuite :
=AdrHyperlien(A1)
Autre solution pour disposer de ses fonctions personnelles dans tous les
classeurs en les appelant simplement par leur nom : les copier dans un classeur
enregistré en macro complémentaire.
Ou, si tu veux pouvoir l'utiliser dans n'importe quel classeur, dans un module
standard du perso.xls.
Inconvénient, pour l'utiliser il faudra la "qualifier" :
=perso.xls!AdrHyperlien(A1)
Remède possible : mettre la propriété IsAddin du perso.xls à True, ensuite :
=AdrHyperlien(A1)
Autre solution pour disposer de ses fonctions personnelles dans tous les
classeurs en les appelant simplement par leur nom : les copier dans un classeur
enregistré en macro complémentaire.
Frédéric Sigonneau, (N°745)
avec la fonction COMBIN (x;y) on peut calculer le nombre de combinaisons possibles. Mais
comment faire pour afficher ou calculer toutes les combinaisons et toutes les permutations ?
Un ensemble de procédures de Myrna Larson permet de faire aussi bien la liste
des combinaisons que des permutations (malgré le nom de la procédure principale
"ListPermutations" qui pourrait laisser croire qu'elle laisse les combinaisons
de côté).
Ci-dessous le code, avec mode d'emploi, à recopier dans un module standard.
Voici une diabolique procédure 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 ou p ; (Combinaison ou 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 1
A4 2
A5 Excel
A6 4
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()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim N As Double
Const BufferSize As Long = 4096
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If
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"
Exit Sub
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 'AddPermutation
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 'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
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 'SavePermutation
des combinaisons que des permutations (malgré le nom de la procédure principale
"ListPermutations" qui pourrait laisser croire qu'elle laisse les combinaisons
de côté).
Ci-dessous le code, avec mode d'emploi, à recopier dans un module standard.
Voici une diabolique procédure 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 ou p ; (Combinaison ou 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 1
A4 2
A5 Excel
A6 4
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()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim N As Double
Const BufferSize As Long = 4096
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown))
End If
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"
Exit Sub
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 'AddPermutation
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 'AddCombination
Private Sub SavePermutation(ItemsChosen() As Integer, _
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 'SavePermutation
Myrna Larson, Frédéric Sigonneau, Serge Garneau, (N°744)