Excel contient plus de 300 fonctions prédéfinies dans une feuille de travail, mais grâce à VBA, on peut créer des fonctions personnalisées.
Ces fonctions personnalisées sont utiles dans les formules de feuille de travail Excel et simplifient le travail et permettent à l’utilisateur de gagner du temps.
Par exemple, la création d'une fonction personnalisée capable de raccourcir les formules de manière significative :
Exemple de formule : =SI(C15="OUI";B15*5.5/100;SI(C15="NON";B15*1.5/100;""))
Cependant, si on veut modifier par la suite cette fonction, on sera obligé de modifier toutes les cellules où elle a été introduite et on conserve une certaine complexité de l'écriture
Alors que sous VBA, il est possible de déclarer la fonction (plus lisible et plus facile à corriger en cas d'erreur) :
Function Exemple_calcul(OUI_NON, CHIFFRE)
If OUI_NON = "oui" Then
Exemple_calcul = CHIFFRE * 5.5 / 100
ElseIf OUI_NON = "non" Then
Exemple_calcul = CHIFFRE * 1.5 / 100
Else
Exemple_calcul = ""
End If
End Function
Dans ce cas, il suffit d'introduire dans une case Excel : =Exemple_calcul(B5) pour obtenir le même résultat qu'avec une fonction SI imbriquée.
Ces fonctions personnalisées fonctionnent exactement de la même façon que celles incluses dans Excel. Ci-après la visualisation de l'exemple ci-dessous.
Comment créer une fonction personnalisée.
Cliquez sur l'onglet "Développeur" pour accéder à la programmation via Visual Basic.
Insérer un module dans votre VBAProject
:
Écrire la fonction :
La déclaration d'une fonction commence par le mot clé "Function" suivi du Nom de la fonction, puis d’une liste d’arguments obligatoires ou facultatifs entre parenthèses séparés les uns des autres par une virgule. Le mot clé "End Function" marque la fin de la fonction. Une fonction a la structure suivante :
Début
déclarations de variables
séquences d'actions
renvoi d'une valeur
Fin
Pour accéder aux fonctions personnalisées dans Excel, cliquez sur fx et choisissez "Personnalisées" dans la fenêtre qui s'ouvre :
Donc maintenant, vous êtes capable de créer vos propres fonctions personnalisées.
Je vous propose quelques exemples très simples :
* Calcul d'un montant HT en fonction du Taux de TVA :
Exemple formule "classsique" : =A4-((B4/100)*5.5)
Avec nouvelle fonction : =HORS_TAXE(A4;5.5)
Programme de la fonction HORS_TAXE :
Option Explicit 'Déclaration des variables obligatoire
Function HORS_TAXE(Montant_TTC, Taux_Tva)
HORS_TAXE = (Montant_TTC / (100 + Taux_Tva) * 100)
End Function
 |
| Affichage forumulaire fonction HT |
* Calcul d'un montant TTC en fonction d'un coût Hors Taxe :
Exemple formule "classique" : =(B4*5.5/100)+B4
Avec nouvelle fonction : =TTC(B4;5.5)
Programme de la fonction TTC :
Option Explicit 'Déclaration des variables obligatoire
Function TTC(Hors_Taxe, Taux_Tva)
TTC = (Hors_Taxe + (Hors_Taxe * Taux_Tva) / 100)
End Function
 |
| Affichage formulaire fonction TTC |
* Calcul d'un montant TTC en fonction de la TVA :
Avec nouvelle fonction : =TTC_A_PARTIR_TVA(B4;B5)
Programme de la fonction TTC :
Option Explicit 'Déclaration des variables obligatoire
Function TTC_A_PARTIR_TVA(Total_TVA, Taux_Tva)
TTC_A_PARTIR_TVA = ((Total_TVA * 100 / Taux_Tva) + Total_TVA)
End Function
* Calcul d'un coût avec marge incluse (exemple marge à 15%) :
Exemple formule "classsique" : =(B4*15/100)+B4
Avec nouvelle fonction : =Total_Prix_Margé(B4;15)
Programme de la fonction Total_Prix_Margé :
Option Explicit 'Déclaration des variables obligatoire
Function Total_Prix_Margé(Prix_Achat, Marge)
Total_Prix_Margé = (Prix_Achat + (Prix_Achat * Marge) / 100)
End Function
 |
| Affichage formulaire fonction Total_Prix_Margé |
* Calcul de la marge dégagé (exemple marge à 15%) :
Exemple formule "classique" : =B4*15/100
Avec nouvelle fonction : =Marge_dégagé(A4;15)
Programme de la fonction Margé_dégagé :
Option Explicit 'Déclaration des variables obligatoire
Function Marge_dégagé(Prix_de_vente, Marge)
Marge_dégagé = (Prix_de_vente * Marge) / 100
End Function
 |
| Affichage formulaire fonction Margé_dégagé |
* Calculer le taux de marge :
Exemple formule "classique" : =(B4-B5)/B5*100
Avec nouvelle fonction : =Taux_de_Marge(Q10;Q9)
Programme de la fonction Taux_de_Marge :
Option Explicit 'Déclaration des variables obligatoire
Function Taux_de_Marge(Prix_de_vente, Prix_Achat)
Taux_de_Marge = (Prix_de_vente - Prix_Achat) / Prix_Achat * 100
End Function
* Calculer une commission par rapport à un chiffre :
Suivant une grille établie
Exemple :
Chiffre en A1 :
Insérer B1 : =COMMISSION(A1)
Résultat : 90 (Renvoie la valeur de la commission suivant la grille établie)
Programme de la fonction =COMMISSION :
Option Explicit 'Déclaration des variables obligatoire
Function COMMISSION(CHIFFRE As Variant) As Variant
If CHIFFRE < 500 Then 'si inférieur à 500 etc....
COMMISSION = CHIFFRE * 0.03
ElseIf CHIFFRE >= 500 And CHIFFRE < 1000 Then
COMMISSION = CHIFFRE * 0.06
ElseIf CHIFFRE >= 1000 And CHIFFRE < 2000 Then
COMMISSION = CHIFFRE * 0.09
ElseIf CHIFFRE >= 200 And CHIFFRE < 5000 Then
COMMISSION = CHIFFRE * 0.12
ElseIf CHIFFRE >= 5000 Then
COMMISSION = CHIFFRE * 0.15
End If
End Function
* Effectuer un total sur différentes plages cumulées (Horizontale et/ou Verticale) :
Fini les totaux ou les sommes de données de colonnes
Insérer A1 : =TOTAL_GENERAL(B1:B4; C1:F1)
Dans le cas présent le total se fait en vertical (B1:B4) + Horizontal (C1:F1)
Fonctionne avec les décimales.
Programme de la fonction =TOTAL_GENERAL :
Option Explicit 'Déclaration des variables obligatoire
Function TOTAL_GENERAL(Optional Plage1 = 0, _
Optional Plage2 = 0, _
Optional Plage3 = 0, _
Optional Plage4 = 0, _
Optional Plage5 = 0, _
Optional Plage6 = 0, _
Optional Plage7 = 0) As Double
Application.Volatile
TOTAL_GENERAL = Application.WorksheetFunction.Sum(Plage1, Plage2, Plage3, Plage4, Plage5, Plage6, Plage7)
End Function
* Effectuer la somme des chiffres non barrés :
Heure en A1, A2, A3 : 10,
Avec nouvelle fonction en A4 : =Somme_Chiffres_non_barrés(A1:A3)
Programme de la fonction =Somme_Chiffres_non_barrés :
Option Explicit 'Déclaration des variables obligatoire
Function Somme_Chiffres_non_barrés(Plage_cellules As Range)
Dim Total As Double
Dim c As Variant
Application.Volatile
Total = 0
For Each c In Plage_cellules
If c.Font.Strikethrough = False Then Total = Total + c.Value
Next
Somme_Chiffres_non_barrés = Total
End Function
* Changer une heure en minutes :
Heure en A1 : 03:10
Exemple formule "classique" en B1 : =24*60*(A1)
Avec nouvelle fonction en B1 : =Heure_en_Minutes (A1)
Programme de la fonction =Heure_en_Minute :
Option Explicit 'Déclaration des variables obligatoire
Function Heure_en_Minute(HEURE)
Heure_en_Minute = 24 * 60 * (HEURE)
End Function
* Calculer des heures supérieures à 24 heures :
Heure en A1 : 00:05:1
Heure en B1 : 23:59:59
Avec nouvelle fonction en C1 : =CALCUL_HEURES_SUP_A_24H(A1+B1;A1+B1)
Résultat : 24:05:09
Programme de la fonction =CALCUL_HEURES_SUP_A_24H
Option Explicit 'Déclaration des variables obligatoire
' Permet de trouver un nombre d'heures > 24 :
Public Function CALCUL_HEURES_SUP_A_24H(ParTemps As Double, Optional ParSecondesAffichees As Boolean = False)
Dim VarJours As Long, VarHeures As Long, VarMinutes As Long, VarSecondes As Long
VarJours = Int(ParTemps)
ParTemps = (ParTemps - VarJours) * 86400 'nombre de secondes
VarSecondes = ParTemps Mod 60
ParTemps = ParTemps - VarSecondes
VarMinutes = (ParTemps Mod 3600) / 60 ' Minutes
ParTemps = ParTemps - VarMinutes * 60
VarHeures = (ParTemps Mod 86400) / 3600 ' Heures
VarHeures = VarHeures + VarJours * 24
If IsMissing(ParSecondesAffichees) Or ParSecondesAffichees = True Then
CALCUL_HEURES_SUP_A_24H = VarHeures & ":" & Format(VarMinutes, "00") & ":" & Format(VarSecondes, "00")
Else
CALCUL_HEURES_SUP_A_24H = VarHeures & ":" & Format(VarMinutes, "00")
End If
End Function
* Calcul d'un montant selon barême horaire :
Heure en A1 (taux horaire) : 80
Fonction en B1 (temps passé) : 08:15
Fonction en C1: =CalculMontantSelonBaremeHoraire(B1;A1)
Résultat : 660
Programme de la fonction =CalculMontantSelonBaremeHoraire :
Option Explicit 'Déclaration des variables obligatoire
Function CalculMontantSelonBaremeHoraire(Heure, TarifHoraire) As Single
CalculMontantSelonBaremeHoraire = Heure * 60 * 24 * (TarifHoraire / 60)
End Function
* Vérifier si une année est bissextile :
Heure en A1 : 2016
Fonction en B1 : =ANNEE_BISSEXTILE(A1)
Résultat : VRAI
Programme de la fonction =ANNEE_BISSEXTILE :
Option Explicit 'Déclaration des variables obligatoire
Function ANNEE_BISSEXTILE(annee As Integer) As Boolean
Dim div4 As Boolean, div100 As Boolean, div400 As Boolean
div4 = annee Mod 4 = 0
div100 = annee Mod 100 = 0
div400 = annee Mod 400 = 0
If div4 And Not div100 Then
ANNEE_BISSEXTILE = True
Else
If div400 Then
ANNEE_BISSEXTILE = True
Else
ANNEE_BISSEXTILE = False
End If
End If
End Function
* Trouver le numéro du jour :
Heure en A1 : 10/06/2015
Exemple formule "classsique" en B1 : =A1-DATE(ANNEE(A1);1;0)
Avec nouvelle fonction en B1 : =Numero_jour(A1)
Résultat : 161 (Renvoie le n° du jour)
Programme de la fonction =Numero_jour(A1) :
Option Explicit 'Déclaration des variables obligatoire
Function Numero_jour(ladate As Date) As Byte
Numero_jour = ladate - DateSerial(Year(Date), 1, 0)
End Function
* Trouver le numéro du trimestre en fonction d'une date :
Heure en A1 : 12/04/2015
Fonction en B1 : =TRIMESTRE(A1)
Résultat : 2 (Renvoie le n° du trimestre)
Programme de la fonction : =TRIMESTRE :
Option Explicit 'Déclaration des variables obligatoire
Function TRIMESTRE(ladate As Date) As Byte
TRIMESTRE = Int((Month(ladate) - 1) / 3) + 1
End Function
* Trouver le numéro du semestre en fonction d'une date :
Heure en A1 : 12/04/2015
Fonction en B1 : =SEMESTRE(A1)
Résultat : 1 (Renvoie le n° du semestre)
Programme de la fonction =SEMESTRE :
Option Explicit 'Déclaration des variables obligatoire
Function SEMESTRE(ladate As Date) As Byte
SEMESTRE = Int((Month(ladate) - 1) / 6) + 1
End Function
* Trouver le NOM du JOUR au lieu d'un chiffre (exemple Dimanche au lieu du chiffre 1) :
Heure en A1 : 12/04/2015
Fonction en B1 : =NOM_DU_JOUR(A1)
Résultat : Dimanche
(Renvoie le nom du jour en fonction du numéro restitué soit :
1 => Dimanche
2 => Lundi
3 => Mardi
4 => Mercredi
5 => Jeudi
6 => Vendredi
7 => Samedi
Programme de la fonction =NOM_DU_JOUR :
Option Explicit 'Déclaration des variables obligatoire
Function NOM_DU_JOUR(InputDate As Date)
Dim NuméroJour As Integer
NuméroJour = Weekday(InputDate, vbSunday)
Select Case NuméroJour
Case 1
NOM_DU_JOUR = "Dimanche"
Case 2
NOM_DU_JOUR = "lundi"
Case 3
NOM_DU_JOUR = "mardi"
Case 4
NOM_DU_JOUR = "mercredi"
Case 5
NOM_DU_JOUR = "Jeudi"
Case 6
NOM_DU_JOUR = "vendredi"
Case 7
NOM_DU_JOUR = "Samedi"
End Select
End Function
* Trouver le dernier jour du mois d'une date inscrite dans une cellule :
Heure en A1 : 15/06/2015
Fonction en B1 : =DernierJourMois(A1)
Résultat : 30/06/2015 (Renvoie le dernier jour du mois)
Programme de la fonction =DernierJourMois :
Option Explicit 'Déclaration des variables obligatoire
Function DernierJourMois(Choix_de_la_Date)
Dim TempDate As Date
TempDate = Choix_de_la_Date
While Month(Choix_de_la_Date) = Month(TempDate)
TempDate = TempDate + 1
Wend
DernierJourMois = TempDate - 1
End Function
* Trouver le premier jour du mois d'une date inscrite dans une cellule :
Function PremierLundiDuMois(Choix_de_la_Date) As Date
Dim PremierDuMois As Date, Numero_Jour As Integer, TYPE_ANNEE As Integer, TYPE_MOIS As Integer
TYPE_ANNEE = Year(Choix_de_la_Date)
TYPE_MOIS = Month(Choix_de_la_Date)
PremierDuMois = DateSerial(TYPE_ANNEE, TYPE_MOIS, 1)
Numero_Jour = Weekday(PremierDuMois, vbMonday)
If Numero_Jour = 1 Then
PremierLundiDuMois = PremierDuMois
Else
PremierLundiDuMois = DateAdd("d", 8 - Weekday(PremierDuMois, vbMonday), PremierDuMois)
End If
End Function
* La fonction =CONCATENER() vue d'une autre façon :
La fonction CONCATENER vous contraint à n'utiliser que 5 plages de critères, dans la fonction suivante la fonction de concaténation a pour argument une plage de cellules contigües
Placer des valeurs dans les cellules de la plage : A1:C1
Fonction en D1 : =CONCATENER_PLUS(A1:C1)
Résultat exemple : aabbcc
Programme de la fonction =CONCATENER_PLUS() :
Option Explicit 'Déclaration des variables obligatoire
Function CONCATENER_PLUS(plage As Range)
Dim texte As String, reference As Range ' Boucle permettant de concaténer chaque "référence" contenue dans "plage" à l'aide du caractère "&"
For Each reference In plage
texte = texte & reference.Value
Next reference
' On renvoie la chaîne "texte" concaténeé '
CONCATENER_PLUS = texte
End Function
Si vous souhaitez ajouter un espace entre chaque valeur de cellule modifier le programme comme suit :
texte = texte &" "& reference.Value
Résultat exemple : aa bb cc
L'espace peut être remplacé par tout autre caractère :
texte = texte &"-"& reference.Value
Résultat exemple : aa-bb-cc
* CONCATENER() avec un caractère séparateur de son choix :
Option Explicit
Function ConcatPlage(plage As Range, séparateur As String, Optional contenant As String) As String
Dim rep As String, c As Range
For Each c In plage
If InStr(c.Value, contenant) > 0 Then
rep = rep & c.Value & séparateur
End If
Next c
ConcatPlage = Left(rep, Len(rep) - Len(séparateur))
End Function
* Chercher le mot le plus fréquent dans une colonne :
Insérer la formule suivante dans une cellule pour définir le mot le plus fréquent dans une plage de cellule (ex. Plage A1:A10 et formule en B1) : =Mot_Frequent(A1:A10)
Programme de la fonction =Mot_Frequent :
Option Explicit 'Déclaration des variables obligatoire
Option Explicit 'Déclaration des variables obligatoire
Function NOM_DU_JOUR(InputDate As Date)
Dim NuméroJour As Integer
NuméroJour = Weekday(InputDate, vbSunday)
Select Case NuméroJour
Case 1
NOM_DU_JOUR = "Dimanche"
Case 2
NOM_DU_JOUR = "lundi"
Case 3
NOM_DU_JOUR = "mardi"
Case 4
NOM_DU_JOUR = "mercredi"
Case 5
NOM_DU_JOUR = "Jeudi"
Case 6
NOM_DU_JOUR = "vendredi"
Case 7
NOM_DU_JOUR = "Samedi"
End Select
End Function
* Trouver le dernier jour du mois d'une date inscrite dans une cellule :
Heure en A1 : 15/06/2015
Fonction en B1 : =DernierJourMois(A1)
Résultat : 30/06/2015 (Renvoie le dernier jour du mois)
Programme de la fonction =DernierJourMois :
Option Explicit 'Déclaration des variables obligatoire
Function DernierJourMois(Choix_de_la_Date)
Dim TempDate As Date
TempDate = Choix_de_la_Date
While Month(Choix_de_la_Date) = Month(TempDate)
TempDate = TempDate + 1
Wend
DernierJourMois = TempDate - 1
End Function
* Trouver le premier jour du mois d'une date inscrite dans une cellule :
Function PremierLundiDuMois(Choix_de_la_Date) As Date
Dim PremierDuMois As Date, Numero_Jour As Integer, TYPE_ANNEE As Integer, TYPE_MOIS As Integer
TYPE_ANNEE = Year(Choix_de_la_Date)
TYPE_MOIS = Month(Choix_de_la_Date)
PremierDuMois = DateSerial(TYPE_ANNEE, TYPE_MOIS, 1)
Numero_Jour = Weekday(PremierDuMois, vbMonday)
If Numero_Jour = 1 Then
PremierLundiDuMois = PremierDuMois
Else
PremierLundiDuMois = DateAdd("d", 8 - Weekday(PremierDuMois, vbMonday), PremierDuMois)
End If
End Function
* La fonction =CONCATENER() vue d'une autre façon :
La fonction CONCATENER vous contraint à n'utiliser que 5 plages de critères, dans la fonction suivante la fonction de concaténation a pour argument une plage de cellules contigües
Placer des valeurs dans les cellules de la plage : A1:C1
Fonction en D1 : =CONCATENER_PLUS(A1:C1)
Résultat exemple : aabbcc
Option Explicit 'Déclaration des variables obligatoire
Function CONCATENER_PLUS(plage As Range)
Dim texte As String, reference As Range ' Boucle permettant de concaténer chaque "référence" contenue dans "plage" à l'aide du caractère "&"
For Each reference In plage
texte = texte & reference.Value
Next reference
' On renvoie la chaîne "texte" concaténeé '
CONCATENER_PLUS = texte
End Function
Si vous souhaitez ajouter un espace entre chaque valeur de cellule modifier le programme comme suit :
texte = texte &" "& reference.Value
Résultat exemple : aa bb cc
L'espace peut être remplacé par tout autre caractère :
texte = texte &"-"& reference.Value
Résultat exemple : aa-bb-cc
* CONCATENER() avec un caractère séparateur de son choix :
Option Explicit
Function ConcatPlage(plage As Range, séparateur As String, Optional contenant As String) As String
Dim rep As String, c As Range
For Each c In plage
If InStr(c.Value, contenant) > 0 Then
rep = rep & c.Value & séparateur
End If
Next c
ConcatPlage = Left(rep, Len(rep) - Len(séparateur))
End Function
* Chercher le mot le plus fréquent dans une colonne :
Insérer la formule suivante dans une cellule pour définir le mot le plus fréquent dans une plage de cellule (ex. Plage A1:A10 et formule en B1) : =Mot_Frequent(A1:A10)
Programme de la fonction =Mot_Frequent :
Option Explicit 'Déclaration des variables obligatoire
Function Mot_Frequent(Plage_Cellule As Range) As String
Dim Mx As Integer
Dim c As Range
Dim Mot As String
For Each c In Plage_Cellule
If Application.CountIf(Plage_Cellule, c.Value) > Mx Then
Mx = Application.CountIf(Plage_Cellule, c.Value)
Mot = c.Value
End If
Next c
Mot_Frequent = Mot
End Function
* Compter une nombre de mot dans une cellule ou une plage de cellule. :
Heure en A1 : Demain c'est jeudi
Fonction en B1 : =COMPTE_LES_MOTS(A1)
Résultat : 3
(Renvoie le nombre de mots)
Programme de la fonction =COMPTE_LES_MOTS :
Option Explicit 'Déclaration des variables obligatoire
Function COMPTE_LES_MOTS(CELLULE_PLAGECELLULE As range) As Long
Dim rCell As Range, lCount As Long
For Each rCell In CELLULE_PLAGECELLULE
lCount = lCount + _
Len(Trim(rCell)) - Len(Replace(Trim(rCell), " ", "")) + 1
Next rCell
COMPTE_LES_MOTS = lCount
End Function
* Supprimer les accents d'une chaîne de caractère
Ce code va vous permettre de transformer de supprimer tous les accents du chaîne de caractères comprenant les lettres suivantes :
ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ
Exemple :
En A1 : éphémère
Avec nouvelle fonction en B1 : =Supprimer_Accents(A1)
Résultat : ephemere
* Inverser le Nom Prénom en Prénom Nom dans une cellule:
Heure en A1 : Patrick Durand
Fonction en B1 : =Nom_Prenom(A1)
Résultat : Durand Patrick
(Inverse le Nom et le Prénom)
Se substitut à la formule : =STXT($A7;1+CHERCHE("µ";SUBSTITUE($A7;" ";"µ";NBCAR($A7)-NBCAR(SUBSTITUE($A7;" ";""))));100)&" "&GAUCHE($A7;CHERCHE("µ";SUBSTITUE($A7;" ";"µ";NBCAR($A7)-NBCAR(SUBSTITUE($A7;" ";"")))))
Programme de la fonction =Nom_Prenom :
Option Explicit 'Déclaration des variables obligatoire
Dim pn, np, n
Public Function Nom_Prenom(np As String)
n = InStrRev(np, " ")
pn = Mid(np, n + 1, Len(np) - n)
Nom_Prenom = pn & " " & Left(np, n - 1)
End Function
Attention ne fonctionne pas avec les noms composés
Fonctionne avec les noms composés
Function Inverse_NOM_PRENOM(chaine)
Application.Volatile
a = Split(chaine, " ")
i = 1
Do While UCase(a(i)) = a(i) And i < UBound(a): i = i + 1: Loop
For k = i To UBound(a): temp = temp & a(k) & " ": Next
For k = LBound(a) To i - 1: temp = temp & a(k) & " ": Next
Inverse_NOM_PRENOM= Trim(temp)
End Function
* Extraire le NOM inscrit en majuscule dans une cellule :
Heure en A1 : Emile RIOU
Fonction en B1 : =NOM(A1)
Résultat : RIOU
Programme de la fonction =NOM() :
Function Nom(CELLULE)
Application.Volatile
Application.Volatile
Set obj = CreateObject("vbscript.regexp")
obj.Pattern = "([A-Z'ÔËÉÈÏ]{2,}\s*-?)+"
Set a = obj.Execute(CELLULE)
If a.Count > 0 Then Nom = a(0) Else Nom = ""
End Function
* Extraire le Prénom inscrit dans une cellule :
Heure en A1 : Emile RIOU
Fonction en B1 : =Pénom(A1)
Résultat : RIOU
Programme de la fonction =Prénom() :
Function Prénom(CELLULE)
Application.Volatile
Set obj = CreateObject("vbscript.regexp")
CELLULE = Replace(Replace(Replace(CELLULE, "M.", ""), "Mme", ""), "Mle", "")
obj.Pattern = "([A-ZÉ][a-zëéèôçï]+\s*-?)+"
Set a = obj.Execute(CELLULE)
If a.Count > 0 Then Prénom = a(0) Else Prénom = ""
End Function
* Extraire l'ADRESSE d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =RUE(A1)
Résultat : 11, rue de Siam
Se substitut à la formule : =GAUCHE(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)-5)"
Programme de la fonction =RUE() :
Function RUE(chaine)
temp = ""
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Do While IsNumeric(Mid(chaine, p, 1)) And p > 1
temp = Mid(chaine, p, 1) & temp
p = p - 1
Loop
RUE = Left(chaine, p)
End Function
* Extraire le CODE POSTAL d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =CodePostal(A1)
Résultat : 29200
Se substitut à la formule : =STXT(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)-4;5)
Programme de la fonction =CodePostal() :
Function CodePostal(chaine)
temp = ""
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Do While IsNumeric(Mid(chaine, p, 1)) And p > 1
temp = Mid(chaine, p, 1) & temp
p = p - 1
Loop
CodePostal = temp
End Function
* Extraire la VILLE d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =Ville(A1)
Résultat : BREST
Se substitut à la formule : =STXT(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)+2;99)
Programme de la fonction =Ville() :
Function Ville(chaine)
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Ville = Mid(chaine, p + 2)
End Function
* EXTRAIRE une adresse MAIL dans une contenu de texte :
Texte en A1 : Mon mail est blog.cellulexcel@gmail.com. Vous….
Fonction en B1 : =Extraction_EMAIL(A)
Résultat : blog.cellulexcel@gmail.com
Programme de la fonction =Extraction_EMAIL() :
Function Extraction_EMAIL(ByVal S As String) As String
Dim X As Long, AtSign As Long
Dim Locale As String, DomainPart As String
Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
Domain = "[A-Za-z0-9._-]"
AtSign = InStr(S, "@")
For X = AtSign To 1 Step -1
If Not Mid(" " & S, X, 1) Like Locale Then
S = Mid(S, X)
If Left(S, 1) = "." Then S = Mid(S, 2)
Exit For
End If
Next
AtSign = InStr(S, "@")
For X = AtSign + 1 To Len(S) + 1
If Not Mid(S & " ", X, 1) Like Domain Then
S = Left(S, X - 1)
If Right(S, 1) = "." Then S = Left(S, Len(S) - 1)
Extraction_EMAIL = S
Exit For
End If
Next
End Function
* Rechercher les mots d'une cellule communs à une plage de cellule :
Texte en A1 : Mon mail est blog.cellulexcel@gmail.com. Exemple
Texte en D2 : mail
Texte en D2 : exemple
Fonction en B1 : =recherche_mot(A1;$D$2:$D$3;0)
Résultat : mail, exemple
Programme de la fonction =Recherche_mot() :
Function Recherche_mot(source, matrice, position)
t = Split(source, " ")
For Each v In t
Set re = matrice.Find(v, lookat:=xlWhole)
If Not re Is Nothing Then rep = rep & re.Offset(, position) & ", "
Next
If rep <> "" Then Recherche_mot = Left(rep, Len(rep) - 2)
End Function
* Transformer des CHIFFRES en LETTRES avec Euros et décimales
Ce code va vous permettre de transformer un chiffre avec décimales en lettre
Exemple :
Chiffre en A1 : 1,5
Avec nouvelle fonction en B1 : =CHIFFRE_LETTRE(A1)
Résultat : 1,5 se transformera en un Euro cinquantes centimes
Dim Mx As Integer
Dim c As Range
Dim Mot As String
For Each c In Plage_Cellule
If Application.CountIf(Plage_Cellule, c.Value) > Mx Then
Mx = Application.CountIf(Plage_Cellule, c.Value)
Mot = c.Value
End If
Next c
Mot_Frequent = Mot
End Function
* Compter une nombre de mot dans une cellule ou une plage de cellule. :
Heure en A1 : Demain c'est jeudi
Fonction en B1 : =COMPTE_LES_MOTS(A1)
Résultat : 3
(Renvoie le nombre de mots)
Programme de la fonction =COMPTE_LES_MOTS :
Option Explicit 'Déclaration des variables obligatoire
Function COMPTE_LES_MOTS(CELLULE_PLAGECELLULE As range) As Long
Dim rCell As Range, lCount As Long
For Each rCell In CELLULE_PLAGECELLULE
lCount = lCount + _
Len(Trim(rCell)) - Len(Replace(Trim(rCell), " ", "")) + 1
Next rCell
COMPTE_LES_MOTS = lCount
End Function
* Supprimer les accents d'une chaîne de caractère
Ce code va vous permettre de transformer de supprimer tous les accents du chaîne de caractères comprenant les lettres suivantes :
ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ
Exemple :
En A1 : éphémère
Avec nouvelle fonction en B1 : =Supprimer_Accents(A1)
Résultat : ephemere
Programme de la fonction =Supprimer_Accents :
Option Explicit 'Déclaration des variables obligatoire
Function Supprimer_Accents(ByVal sChaine As String) As String
Dim sTmp As String, i As Long, p As Long
Const sCarAccent As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
Const sCarSansAccent As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
sTmp = sChaine
For i = 1 To Len(sTmp)
p = InStr(sCarAccent, Mid(sTmp, i, 1))
If p > 0 Then Mid$(sTmp, i, 1) = Mid$(sCarSansAccent, p, 1)
Next i
SupprimerAccents = sTmp
End Function
Option Explicit 'Déclaration des variables obligatoire
Function Supprimer_Accents(ByVal sChaine As String) As String
Dim sTmp As String, i As Long, p As Long
Const sCarAccent As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
Const sCarSansAccent As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
sTmp = sChaine
For i = 1 To Len(sTmp)
p = InStr(sCarAccent, Mid(sTmp, i, 1))
If p > 0 Then Mid$(sTmp, i, 1) = Mid$(sCarSansAccent, p, 1)
Next i
SupprimerAccents = sTmp
End Function
* Inverser le Nom Prénom en Prénom Nom dans une cellule:
Heure en A1 : Patrick Durand
Fonction en B1 : =Nom_Prenom(A1)
Résultat : Durand Patrick
(Inverse le Nom et le Prénom)
Se substitut à la formule : =STXT($A7;1+CHERCHE("µ";SUBSTITUE($A7;" ";"µ";NBCAR($A7)-NBCAR(SUBSTITUE($A7;" ";""))));100)&" "&GAUCHE($A7;CHERCHE("µ";SUBSTITUE($A7;" ";"µ";NBCAR($A7)-NBCAR(SUBSTITUE($A7;" ";"")))))
Programme de la fonction =Nom_Prenom :
Option Explicit 'Déclaration des variables obligatoire
Dim pn, np, n
Public Function Nom_Prenom(np As String)
n = InStrRev(np, " ")
pn = Mid(np, n + 1, Len(np) - n)
Nom_Prenom = pn & " " & Left(np, n - 1)
End Function
Attention ne fonctionne pas avec les noms composés
Fonctionne avec les noms composés
Function Inverse_NOM_PRENOM(chaine)
Application.Volatile
a = Split(chaine, " ")
i = 1
Do While UCase(a(i)) = a(i) And i < UBound(a): i = i + 1: Loop
For k = i To UBound(a): temp = temp & a(k) & " ": Next
For k = LBound(a) To i - 1: temp = temp & a(k) & " ": Next
Inverse_NOM_PRENOM= Trim(temp)
End Function
* Extraire le NOM inscrit en majuscule dans une cellule :
Heure en A1 : Emile RIOU
Fonction en B1 : =NOM(A1)
Résultat : RIOU
Programme de la fonction =NOM() :
Function Nom(CELLULE)
Application.Volatile
Application.Volatile
Set obj = CreateObject("vbscript.regexp")
obj.Pattern = "([A-Z'ÔËÉÈÏ]{2,}\s*-?)+"
Set a = obj.Execute(CELLULE)
If a.Count > 0 Then Nom = a(0) Else Nom = ""
End Function
* Extraire le Prénom inscrit dans une cellule :
Heure en A1 : Emile RIOU
Fonction en B1 : =Pénom(A1)
Résultat : RIOU
Programme de la fonction =Prénom() :
Function Prénom(CELLULE)
Application.Volatile
Set obj = CreateObject("vbscript.regexp")
CELLULE = Replace(Replace(Replace(CELLULE, "M.", ""), "Mme", ""), "Mle", "")
obj.Pattern = "([A-ZÉ][a-zëéèôçï]+\s*-?)+"
Set a = obj.Execute(CELLULE)
If a.Count > 0 Then Prénom = a(0) Else Prénom = ""
End Function
* Extraire l'ADRESSE d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =RUE(A1)
Résultat : 11, rue de Siam
Se substitut à la formule : =GAUCHE(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)-5)"
Programme de la fonction =RUE() :
Function RUE(chaine)
temp = ""
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Do While IsNumeric(Mid(chaine, p, 1)) And p > 1
temp = Mid(chaine, p, 1) & temp
p = p - 1
Loop
RUE = Left(chaine, p)
End Function
* Extraire le CODE POSTAL d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =CodePostal(A1)
Résultat : 29200
Se substitut à la formule : =STXT(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)-4;5)
Programme de la fonction =CodePostal() :
Function CodePostal(chaine)
temp = ""
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Do While IsNumeric(Mid(chaine, p, 1)) And p > 1
temp = Mid(chaine, p, 1) & temp
p = p - 1
Loop
CodePostal = temp
End Function
* Extraire la VILLE d'une adresse inscrite dans une cellule :
Heure en A1 : 11, rue de Siam 29200 BREST
Fonction en B1 : =Ville(A1)
Résultat : BREST
Se substitut à la formule : =STXT(A1;NBCAR(A1)-EQUIV(VRAI;ESTNUM(--(STXT(A1;NBCAR(A1)-LIGNE($1:$255);1)));0)+2;99)
Programme de la fonction =Ville() :
Function Ville(chaine)
p = Len(chaine)
Do While Not IsNumeric(Mid(chaine, p, 1)) And p > 1
p = p - 1
Loop
Ville = Mid(chaine, p + 2)
End Function
* EXTRAIRE une adresse MAIL dans une contenu de texte :
Texte en A1 : Mon mail est blog.cellulexcel@gmail.com. Vous….
Fonction en B1 : =Extraction_EMAIL(A)
Résultat : blog.cellulexcel@gmail.com
Programme de la fonction =Extraction_EMAIL() :
Function Extraction_EMAIL(ByVal S As String) As String
Dim X As Long, AtSign As Long
Dim Locale As String, DomainPart As String
Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
Domain = "[A-Za-z0-9._-]"
AtSign = InStr(S, "@")
For X = AtSign To 1 Step -1
If Not Mid(" " & S, X, 1) Like Locale Then
S = Mid(S, X)
If Left(S, 1) = "." Then S = Mid(S, 2)
Exit For
End If
Next
AtSign = InStr(S, "@")
For X = AtSign + 1 To Len(S) + 1
If Not Mid(S & " ", X, 1) Like Domain Then
S = Left(S, X - 1)
If Right(S, 1) = "." Then S = Left(S, Len(S) - 1)
Extraction_EMAIL = S
Exit For
End If
Next
End Function
* Rechercher les mots d'une cellule communs à une plage de cellule :
Texte en A1 : Mon mail est blog.cellulexcel@gmail.com. Exemple
Texte en D2 : mail
Texte en D2 : exemple
Fonction en B1 : =recherche_mot(A1;$D$2:$D$3;0)
Résultat : mail, exemple
Programme de la fonction =Recherche_mot() :
Function Recherche_mot(source, matrice, position)
t = Split(source, " ")
For Each v In t
Set re = matrice.Find(v, lookat:=xlWhole)
If Not re Is Nothing Then rep = rep & re.Offset(, position) & ", "
Next
If rep <> "" Then Recherche_mot = Left(rep, Len(rep) - 2)
End Function
* Transformer des CHIFFRES en LETTRES avec Euros et décimales
Ce code va vous permettre de transformer un chiffre avec décimales en lettre
Exemple :
Chiffre en A1 : 1,5
Avec nouvelle fonction en B1 : =CHIFFRE_LETTRE(A1)
Résultat : 1,5 se transformera en un Euro cinquantes centimes
Programme de la fonction =CHIFFRE_LETTRE :
Option Explicit 'Déclaration des variables obligatoire
Option Explicit 'Déclaration des variables obligatoire
Function CHIFFRE_LETTRE(chiffre) ' Youky
Dim Nombre As Variant, Entier_naturel As Variant
Nombre = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", _
"huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix sept", _
"dix huit", "dix neuf", "vingt", "vingt et un", "vingt deux", "vingt trois", "vingt quatre", _
"vingt cinq", "vingt six", "vingt sept", "vingt huit", "vingt neuf", "trente", "trente et un", _
"trente deux", "trente trois", "trente quatre", "trente cinq", "trente six", "trente sept", _
"trente huit", "trente neuf", "quarante", "quarante et un", "quarante deux", "quarante trois", _
"quarante quatre", "quarante cinq", "quarante six", "quarante sept", "quarante huit", _
"quarante neuf", "cinquante", "cinquante et un", "cinquante deux", "cinquante trois", _
"cinquante quatre", "cinquante cinq", "cinquante six", "cinquante sept", "cinquante huit", _
"cinquante neuf", "soixante", "soixante et un", "soixante deux", "soixante trois", _
"soixante quatre", "soixante cinq", "soixante six", "soixante sept", "soixante huit", _
"soixante neuf", "soixante dix", "soixante et onze", "soixante douze", "soixante treize", _
"soixante quatorze", "soixante quinze", "soixante seize", "soixante dix sept", _
"soixante dix huit", "soixante dix neuf", "quatre-vingts", "quatre-vingt un", _
"quatre-vingt deux", "quatre-vingt trois", "quatre-vingt quatre", "quatre-vingt cinq", _
"quatre-vingt six", "quatre-vingt sept", "quatre-vingt huit", "quatre-vingt neuf", _
"quatre-vingt dix", "quatre-vingt onze", "quatre-vingt douze", "quatre-vingt treize", _
"quatre-vingt quatorze", "quatre-vingt quinze", "quatre-vingt seize", "quatre-vingt dix sept", _
"quatre-vingt dix huit", "quatre-vingt dix neuf")
Entier_naturel = Array("", "billions", "milliards", "millions", "mille", "Euros", "billion", _
"milliard", "million", "mille", "Euro")
sp = Space(1)
chaine = "00000000000000"
centime = chiffre * 100 - (Int(chiffre) * 100)
chiffre = Str(Int(chiffre)): lg = Len(chiffre) - 1: chiffre = Right(chiffre, lg): lg = Len(chiffre)
If lg < 15 Then chaine = Mid(chaine, 1, (15 - lg)) Else chaine = ""
chiffre = chaine + chiffre
gp = 1
For k = 1 To 5
x = Mid(chiffre, gp, 1): c = Nombre(Val(x))
x = Mid(chiffre, gp + 1, 2): d = Nombre(Val(x))
If k = 5 Then
If t2 <> "" And c & d = "" Then mydz = "Euros" & sp: GoTo fin
If t <> "" And c = "" And d = "un" Then mydz = "un Euros" & sp: GoTo fin
If t <> "" And t2 = "" And c & d = "" Then mydz = "d'Euros" & sp: GoTo fin
If t & c & d = "" Then myct = "": mydz = "": GoTo fin
End If
If c & d = "" Then GoTo fin
If d = "" And c <> "" And c <> "un" Then mydz = c & sp & "cents " & Entier_naturel(k) & sp: GoTo fin
If d = "" And c = "un" Then mydz = "cent " & Entier_naturel(k) & sp: GoTo fin
If d = "un" And c = "" Then myct = IIf(k = 4, Entier_naturel(k) & sp, "un " & Entier_naturel(k + 5) & sp): GoTo fin
If d <> "" And c = "un" Then mydz = "cent" & sp
If d <> "" And c <> "" And c <> "un" Then mydz = c & sp & "cent" + sp
myct = d & sp & Entier_naturel(k) & sp
fin:
t2 = mydz & myct
t = t & mydz & myct
mydz = "": myct = ""
gp = gp + 3
Next
d = Nombre(centime)
If t <> "" Then myct = IIf(centime = 1, " centime", " centimes")
If t = "" Then myct = IIf(centime = 1, " centime d'Euro", " centimes d'Euro")
If centime = 0 Then d = "": myct = ""
CHIFFRE_LETTRE = t & d & myct
End Function
Et pour le fun.... pour nous éviter des formules "Hyper Complexe"
* Calcul AGE :
En A1 : Date de naissance de la personne format : 01/04/1914
En B1 : =AUJOURDHUI()
Exemple formule "classsique" : =DATEDIF(A1;AUJOURDHUI();"y")&SI(DATEDIF(A1;AUJOURDHUI();"y")>1;" ans, ";" an, ")&DATEDIF(A1;AUJOURDHUI();"ym")&" mois, "&DATEDIF(A1;AUJOURDHUI();"md")&SI(DATEDIF(A1;AUJOURDHUI();"md")>1;" jours";" jour")
Avec nouvelle fonction : =calcul_AGE(A1;B1)
Programme de la fonction calcul_AGE
Option Explicit 'Déclaration des variables obligatoire
Public Function Calcul_AGE(Date1 As Date, Date2 As Date) As String
Dim DATE_NAISSANCE As Long, DATE_JOUR As Long
Dim Elt As Long
Dim x As String, y As String, z As String
DATE_NAISSANCE = Int(Date1): DATE_JOUR = Int(Date2)
If DATE_JOUR < DATE_NAISSANCE Then
Calcul_AGE = "Date invalide"
Exit Function
End If
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""y""")
If Elt > 0 Then x = Elt & IIf(Elt > 1, " ans, ", " an, ")
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""ym""")
If Elt > 0 Then y = Elt & " mois, "
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""md""")
If Elt > 0 Then z = Elt & IIf(Elt > 1, " jours", " jour")
Calcul_AGE = x + y + z
If Right(Calcul_AGE, 2) = ", " Then Calcul_AGE = Left(Calcul_AGE, Len(Calcul_AGE) - 2)
End Function
* Convertir des centimètres en pouces :
En A1 : 6
Exemple formule "classsique" : =A1/2,54
Avec nouvelle fonction : =Cm_Pouces(A1)
Résultat exemple : 8,66141732283465
Programme de la fonction =Cm_Pouces() :
Option Explicit 'Déclaration des variables obligatoire
Function Cm_Pouces(Cm)
Application.Volatile
Cm_Pouces = Cm / 2.54
End Function
* Et évidemment l'inverse des pouces en centimètres :
Exemple formule "classsique" : =A1*2,54
Avec nouvelle fonction : = Pouces_Cm(A1)
Programme de la fonction =Cm_Pouces_Cm() :
Option Explicit 'Déclaration des variables obligatoire
Function Pouces_Cm(Pouces)
Application.Volatile
Pouces_Cm = Pouces * 2.54
End Function
* Numéro de la couleur de la cellule :
Function NumCoulCel(C As Object)
Application.Volatile True
NumCoulCel = Abs(C.Interior.ColorIndex)
End Function
Dim Nombre As Variant, Entier_naturel As Variant
Nombre = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", _
"huit", "neuf", "dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix sept", _
"dix huit", "dix neuf", "vingt", "vingt et un", "vingt deux", "vingt trois", "vingt quatre", _
"vingt cinq", "vingt six", "vingt sept", "vingt huit", "vingt neuf", "trente", "trente et un", _
"trente deux", "trente trois", "trente quatre", "trente cinq", "trente six", "trente sept", _
"trente huit", "trente neuf", "quarante", "quarante et un", "quarante deux", "quarante trois", _
"quarante quatre", "quarante cinq", "quarante six", "quarante sept", "quarante huit", _
"quarante neuf", "cinquante", "cinquante et un", "cinquante deux", "cinquante trois", _
"cinquante quatre", "cinquante cinq", "cinquante six", "cinquante sept", "cinquante huit", _
"cinquante neuf", "soixante", "soixante et un", "soixante deux", "soixante trois", _
"soixante quatre", "soixante cinq", "soixante six", "soixante sept", "soixante huit", _
"soixante neuf", "soixante dix", "soixante et onze", "soixante douze", "soixante treize", _
"soixante quatorze", "soixante quinze", "soixante seize", "soixante dix sept", _
"soixante dix huit", "soixante dix neuf", "quatre-vingts", "quatre-vingt un", _
"quatre-vingt deux", "quatre-vingt trois", "quatre-vingt quatre", "quatre-vingt cinq", _
"quatre-vingt six", "quatre-vingt sept", "quatre-vingt huit", "quatre-vingt neuf", _
"quatre-vingt dix", "quatre-vingt onze", "quatre-vingt douze", "quatre-vingt treize", _
"quatre-vingt quatorze", "quatre-vingt quinze", "quatre-vingt seize", "quatre-vingt dix sept", _
"quatre-vingt dix huit", "quatre-vingt dix neuf")
Entier_naturel = Array("", "billions", "milliards", "millions", "mille", "Euros", "billion", _
"milliard", "million", "mille", "Euro")
sp = Space(1)
chaine = "00000000000000"
centime = chiffre * 100 - (Int(chiffre) * 100)
chiffre = Str(Int(chiffre)): lg = Len(chiffre) - 1: chiffre = Right(chiffre, lg): lg = Len(chiffre)
If lg < 15 Then chaine = Mid(chaine, 1, (15 - lg)) Else chaine = ""
chiffre = chaine + chiffre
gp = 1
For k = 1 To 5
x = Mid(chiffre, gp, 1): c = Nombre(Val(x))
x = Mid(chiffre, gp + 1, 2): d = Nombre(Val(x))
If k = 5 Then
If t2 <> "" And c & d = "" Then mydz = "Euros" & sp: GoTo fin
If t <> "" And c = "" And d = "un" Then mydz = "un Euros" & sp: GoTo fin
If t <> "" And t2 = "" And c & d = "" Then mydz = "d'Euros" & sp: GoTo fin
If t & c & d = "" Then myct = "": mydz = "": GoTo fin
End If
If c & d = "" Then GoTo fin
If d = "" And c <> "" And c <> "un" Then mydz = c & sp & "cents " & Entier_naturel(k) & sp: GoTo fin
If d = "" And c = "un" Then mydz = "cent " & Entier_naturel(k) & sp: GoTo fin
If d = "un" And c = "" Then myct = IIf(k = 4, Entier_naturel(k) & sp, "un " & Entier_naturel(k + 5) & sp): GoTo fin
If d <> "" And c = "un" Then mydz = "cent" & sp
If d <> "" And c <> "" And c <> "un" Then mydz = c & sp & "cent" + sp
myct = d & sp & Entier_naturel(k) & sp
fin:
t2 = mydz & myct
t = t & mydz & myct
mydz = "": myct = ""
gp = gp + 3
Next
d = Nombre(centime)
If t <> "" Then myct = IIf(centime = 1, " centime", " centimes")
If t = "" Then myct = IIf(centime = 1, " centime d'Euro", " centimes d'Euro")
If centime = 0 Then d = "": myct = ""
CHIFFRE_LETTRE = t & d & myct
End Function
Et pour le fun.... pour nous éviter des formules "Hyper Complexe"
* Calcul AGE :
En A1 : Date de naissance de la personne format : 01/04/1914
En B1 : =AUJOURDHUI()
Exemple formule "classsique" : =DATEDIF(A1;AUJOURDHUI();"y")&SI(DATEDIF(A1;AUJOURDHUI();"y")>1;" ans, ";" an, ")&DATEDIF(A1;AUJOURDHUI();"ym")&" mois, "&DATEDIF(A1;AUJOURDHUI();"md")&SI(DATEDIF(A1;AUJOURDHUI();"md")>1;" jours";" jour")
Avec nouvelle fonction : =calcul_AGE(A1;B1)
Programme de la fonction calcul_AGE
Option Explicit 'Déclaration des variables obligatoire
Public Function Calcul_AGE(Date1 As Date, Date2 As Date) As String
Dim DATE_NAISSANCE As Long, DATE_JOUR As Long
Dim Elt As Long
Dim x As String, y As String, z As String
DATE_NAISSANCE = Int(Date1): DATE_JOUR = Int(Date2)
If DATE_JOUR < DATE_NAISSANCE Then
Calcul_AGE = "Date invalide"
Exit Function
End If
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""y""")
If Elt > 0 Then x = Elt & IIf(Elt > 1, " ans, ", " an, ")
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""ym""")
If Elt > 0 Then y = Elt & " mois, "
Elt = Evaluate("DATEDIF(" & DATE_NAISSANCE & "," & DATE_JOUR & ",""md""")
If Elt > 0 Then z = Elt & IIf(Elt > 1, " jours", " jour")
Calcul_AGE = x + y + z
If Right(Calcul_AGE, 2) = ", " Then Calcul_AGE = Left(Calcul_AGE, Len(Calcul_AGE) - 2)
End Function
* Convertir des centimètres en pouces :
En A1 : 6
Exemple formule "classsique" : =A1/2,54
Avec nouvelle fonction : =Cm_Pouces(A1)
Résultat exemple : 8,66141732283465
Programme de la fonction =Cm_Pouces() :
Option Explicit 'Déclaration des variables obligatoire
Function Cm_Pouces(Cm)
Application.Volatile
Cm_Pouces = Cm / 2.54
End Function
* Et évidemment l'inverse des pouces en centimètres :
Exemple formule "classsique" : =A1*2,54
Avec nouvelle fonction : = Pouces_Cm(A1)
Programme de la fonction =Cm_Pouces_Cm() :
Option Explicit 'Déclaration des variables obligatoire
Function Pouces_Cm(Pouces)
Application.Volatile
Pouces_Cm = Pouces * 2.54
End Function
* Numéro de la couleur de la cellule :
Function NumCoulCel(C As Object)
Application.Volatile True
NumCoulCel = Abs(C.Interior.ColorIndex)
End Function
* Numéro de la couleur de la police d'une cellule :
Function NumCoulFont(C As Object)
Application.Volatile True
NumCoulFont = Abs(C.Font.ColorIndex)
End Function
Function Somme_des_Couleurs(Plage_de_données As Range, choix_Couleur As Range) As Long
Dim Cellule As Range
Dim Couleur_sélectionnée As Long
Couleur_sélectionnée = choix_Couleur.Interior.ColorIndex
For Each Cellule In Plage_de_données
If Cellule.Interior.ColorIndex = Couleur_sélectionnée Then
Somme_des_Couleurs = Somme_des_Couleurs + 1
End If
Next Cellule
End Function)
* Lister sans doublons les éléments d'une plage de cellules vers une autre plage de cellules :
Sélectionnez une plage de cellule, suffisamment grande pour lister les éléments)
Exemple éléments à trier et lister :
Sélectionnez une plage de cellule où les éléments seront mentionnés. (Ex. de B1:B30)
Ajoutez la formule suivante =SansDoublonsTrié(A1:A50) ce qui va correspondre à trier sans doublon la plage de cellule A1:A50.
Validez par Ctrl + Maj + Entrée pour avoir la formule suivante {=SansDoublonsTrié(A1:A50)} dans les cellules de la plabe B1:B30
Programme de la fonction =SansDoublonsTrié :
Function SansDoublonsTrié(champ As Range)
Set mondico = CreateObject("Scripting.Dictionary")
mondico.CompareMode = vbTextCompare
temp = champ
For Each c In temp
If c <> "" Then mondico(c) = ""
Next c
Dim b()
ReDim b(1 To Application.Caller.Rows.Count)
i = 1
For Each c In mondico.keys
b(i) = c
i = i + 1
Next
Call tri(b, 1, mondico.Count)
SansDoublonsTrié = Application.Transpose(b)
End Function
Sub tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
* Trouver la valeur de la dernières cellule non vide d'une ligne :
En A1 : 6 En B1 : 10
Exemple formule "matricielle" : =INDEX(1:1;MAX(SI(ESTERREUR(1:1);COLONNE(1:1);SI(1:1="";0;COLONNE(1:1))))) validation avec CTRL + MAJ + ENTREE
Avec nouvelle fonction : = Valeur_dernière_cellule(1) indiquer le numéro de la ligne
Résultat exemple : 10
Programme de la fonction =Valeur_dernière_cellule() :
Option Explicit 'Déclaration des variables obligatoire
Function Valeur_dernière_cellule(ligne As Long)
Application.Volatile
Valeur_dernière_cellule = Rows(ligne).Cells(255).End(xlToLeft)
End Function
* Calculer les intérêts :
Programme de la fonction =Calculer_Interet() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Interet(ByVal Capital As Long, ByVal Taux As Double, ByVal Duree As Integer) As Currency
Calculer_Interet = Format((Capital * Taux / 100 * Duree), "Currency")
End Function
* Calculer la surface d'un carré :
Programme de la fonction =Calcul_Surface_Carre() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Carre(côté As Double)
Calcul_Surface_Carre = Côté * Côté
End Function
Si vous souhaitez avoir le résultat sous forme 0,00 m², modifier le code pour lire :
Calcul_Surface_Carre = Format((côté * côté), "# ##0.00 m²")
* Calculer la surface d'un rectangle :
Programme de la fonction =Calcul_Surface_Rectangle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Rectangle(Longueur As Double, Largeur As Double)
Calcul_Surface_Rectangle = Longueur * Largeur
End Function
* Calculer la surface d'un cercle :
Programme de la fonction =Calcul_Surface_Cercle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Cercle(Rayon As Double)
Const Pi = 3.14159265358979
Calcul_Surface_Cercle = Pi * Rayon ^ 2
Application.Volatile True
NumCoulFont = Abs(C.Font.ColorIndex)
End Function
* Compter le nombre de cellule de même couleur dans une plage de cellules :
Option ExplicitFunction Somme_des_Couleurs(Plage_de_données As Range, choix_Couleur As Range) As Long
Dim Cellule As Range
Dim Couleur_sélectionnée As Long
Couleur_sélectionnée = choix_Couleur.Interior.ColorIndex
For Each Cellule In Plage_de_données
If Cellule.Interior.ColorIndex = Couleur_sélectionnée Then
Somme_des_Couleurs = Somme_des_Couleurs + 1
End If
Next Cellule
End Function)
* Lister sans doublons les éléments d'une plage de cellules vers une autre plage de cellules :
Sélectionnez une plage de cellule, suffisamment grande pour lister les éléments)
Exemple éléments à trier et lister :
Sélectionnez une plage de cellule où les éléments seront mentionnés. (Ex. de B1:B30)
Ajoutez la formule suivante =SansDoublonsTrié(A1:A50) ce qui va correspondre à trier sans doublon la plage de cellule A1:A50.
Validez par Ctrl + Maj + Entrée pour avoir la formule suivante {=SansDoublonsTrié(A1:A50)} dans les cellules de la plabe B1:B30
Programme de la fonction =SansDoublonsTrié :
Function SansDoublonsTrié(champ As Range)
Set mondico = CreateObject("Scripting.Dictionary")
mondico.CompareMode = vbTextCompare
temp = champ
For Each c In temp
If c <> "" Then mondico(c) = ""
Next c
Dim b()
ReDim b(1 To Application.Caller.Rows.Count)
i = 1
For Each c In mondico.keys
b(i) = c
i = i + 1
Next
Call tri(b, 1, mondico.Count)
SansDoublonsTrié = Application.Transpose(b)
End Function
Sub tri(a, gauc, droi) ' Quick sort
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
* Trouver la valeur de la dernières cellule non vide d'une ligne :
En A1 : 6 En B1 : 10
Exemple formule "matricielle" : =INDEX(1:1;MAX(SI(ESTERREUR(1:1);COLONNE(1:1);SI(1:1="";0;COLONNE(1:1))))) validation avec CTRL + MAJ + ENTREE
Avec nouvelle fonction : = Valeur_dernière_cellule(1) indiquer le numéro de la ligne
Résultat exemple : 10
Programme de la fonction =Valeur_dernière_cellule() :
Option Explicit 'Déclaration des variables obligatoire
Function Valeur_dernière_cellule(ligne As Long)
Application.Volatile
Valeur_dernière_cellule = Rows(ligne).Cells(255).End(xlToLeft)
End Function
* Calculer les intérêts :
Programme de la fonction =Calculer_Interet() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Interet(ByVal Capital As Long, ByVal Taux As Double, ByVal Duree As Integer) As Currency
Calculer_Interet = Format((Capital * Taux / 100 * Duree), "Currency")
End Function
* Calculer la surface d'un carré :
Programme de la fonction =Calcul_Surface_Carre() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Carre(côté As Double)
Calcul_Surface_Carre = Côté * Côté
End Function
Si vous souhaitez avoir le résultat sous forme 0,00 m², modifier le code pour lire :
Calcul_Surface_Carre = Format((côté * côté), "# ##0.00 m²")
* Calculer la surface d'un rectangle :
Programme de la fonction =Calcul_Surface_Rectangle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Rectangle(Longueur As Double, Largeur As Double)
Calcul_Surface_Rectangle = Longueur * Largeur
End Function
* Calculer la surface d'un cercle :
Programme de la fonction =Calcul_Surface_Cercle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calcul_Surface_Cercle(Rayon As Double)
Const Pi = 3.14159265358979
Calcul_Surface_Cercle = Pi * Rayon ^ 2
End Function
* Calculer la surface total d'un cylindre (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Aire_Cylindre() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Aire_Cylindre(Rayon As Double, Hauteur As Double)
Const Pi = 3.14159265358979
Calculer_Aire_Cylindre = Round((2 * Pi * Rayon * Hauteur) + (2 * Pi * Rayon ^ 2), 2)
End Function
* Calculer la surface total d'un triangle (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_Triangle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_Triangle(Base As Double, Hauteur As Double)
Calculer_Surface_Triangle = Round((Base * Hauteur) / 2), 2)
End Function
* Calculer la surface total d'une sphère (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_sphere() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_sphere(Rayon As Double)
Const Pi = 3.14159265358979
Calculer_Surface_sphere = Round((4 * Pi * Rayon ^ 2), 2)
End Function
* Calculer la surface total d'un ANNEAU (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_ANNEAU() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_ANNEAU(GrandRayon As Double, PetitRayon As Double)
Const Pi = 3.14159265358979
Function Calculer_Surface_ANNEAU(GrandRayon, PetitRayon)
Const Pi = 3.14159265358979
Calculer_Surface_ANNEAU = Round(Pi * ((GrandRayon ^ 2) - (PetitRayon ^ 2)), 2)
End Function End Function
* Calculer la surface total d'un CÔNE (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_CONE() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_CONE(Rayon As Double, Hauteur As Double)
Const Pi = 3.14159265358979
Calculer_Surface_CONE = Round(Pi * Rayon * Sqr((Rayon ^ 2) + (Hauteur ^ 2)), 2)
End Function
* Calculer la surface total d'un cylindre (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Aire_Cylindre() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Aire_Cylindre(Rayon As Double, Hauteur As Double)
Const Pi = 3.14159265358979
Calculer_Aire_Cylindre = Round((2 * Pi * Rayon * Hauteur) + (2 * Pi * Rayon ^ 2), 2)
End Function
* Calculer la surface total d'un triangle (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_Triangle() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_Triangle(Base As Double, Hauteur As Double)
Calculer_Surface_Triangle = Round((Base * Hauteur) / 2), 2)
End Function
* Calculer la surface total d'une sphère (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_sphere() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_sphere(Rayon As Double)
Const Pi = 3.14159265358979
Calculer_Surface_sphere = Round((4 * Pi * Rayon ^ 2), 2)
End Function
* Calculer la surface total d'un ANNEAU (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_ANNEAU() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_ANNEAU(GrandRayon As Double, PetitRayon As Double)
Const Pi = 3.14159265358979
Function Calculer_Surface_ANNEAU(GrandRayon, PetitRayon)
Const Pi = 3.14159265358979
Calculer_Surface_ANNEAU = Round(Pi * ((GrandRayon ^ 2) - (PetitRayon ^ 2)), 2)
End Function End Function
* Calculer la surface total d'un CÔNE (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Surface_CONE() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Surface_CONE(Rayon As Double, Hauteur As Double)
Const Pi = 3.14159265358979
Calculer_Surface_CONE = Round(Pi * Rayon * Sqr((Rayon ^ 2) + (Hauteur ^ 2)), 2)
End Function
* Calculer le VOLUME d'un CUBE (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Volume_CUBE() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Volume_CUBE(ARETE As Double)
Calculer_Volume_CUBE = ARETE * ARETE * ARETE
End Function
Programme de la fonction =Calculer_Volume_CUBE() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Volume_CUBE(ARETE As Double)
Calculer_Volume_CUBE = ARETE * ARETE * ARETE
End Function
* Calculer le VOLUME d'une SPERE :
Programme de la fonction =Calculer_volume_sphere() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_volume_sphere(Rayon)
Const Pi = 3.14159265358979
Calculer_volume_sphere = (4 * Pi * Rayon ^ 3) / 3
End Function
* Calculer le VOLUME en LITRE d'un CUBE (Arrondi à deux chiffres après la virgule) :
Programme de la fonction =Calculer_Volume_CUBE_LITRE() :
Option Explicit 'Déclaration des variables obligatoire
Function Calculer_Volume_CUBE_LITRE(ARETE As Double)
Calculer_Volume_CUBE_LITRE = Format((ARETE * ARETE * ARETE) * 1000, "# ##0.00 litres")
End Function
* Donner une longueur stricte à un texte, et compléter à gauche ou à droite par un caractère de son choix :
En A1 : Emile
Fonction en B1 : =Remplissage(A1;20;"gauche";".")
Résultat : Emile...............
Option Explicit 'Déclaration des variables obligatoire
'Explications
'Admettons l 'exemple Emile à remplir dans une zone de 20 caracteres avec des points à droite. Le résultat sera : Emile.......
' Champ Texte : Texte à utiliser EXEMPLE : Emile
' Longueur : Longueur totale EXEMPLE : 20
' Cote : Doit-il être aligné à gauche ou à droite ? EXEMPLE : "Gauche"
' CaractereRemplissage : avec quoi complète-t-on ? EXEMPLE : "."
Function Remplissage(Texte As String, Longueur As Integer, Cote As String, CaractereRemplissage As String) As String
Dim QteARemplir As Integer
Dim Ctr As Integer
Dim SuiteCaractere As String
' Si le texte est supérieur à la zone à remplir, on prend la partie de gauche du texte : If Len(Texte) >= Longueur Then
Texte = Left$(Texte, Longueur)
Remplissage = Texte
Exit Function
End If
QteARemplir = Longueur - Len(Texte)
If Cote = "gauche" Then
For Ctr = 1 To QteARemplir
Texte = Texte & CaractereRemplissage
Next
Else
For Ctr = 1 To QteARemplir
SuiteCaractere = SuiteCaractere & CaractereRemplissage
Next
Texte = SuiteCaractere & Texte
End If
Remplissage = Texte
End Function
* Insérer le nom de la feuille dans une cellule :
Dans une feuille nommée "EMILE"
En A1 : =Nom_Feuille()
Résultat en A1 : EMILE
Programme de la fonction =Nom_Feuille() :
Option Explicit 'Déclaration des variables obligatoire
Function Nom_Feuille() As String
Application.Volatile
Nom_Feuille = Application.Caller.Parent.Name
End Function
* Conversion d'une formule en Anglais :
En A2 : 10.2
En A1: =ARRONDI(A2;0)
En C1 : =anglais(B1)
Résultat en C1 : =ROUND(A2,1)
Programme de la fonction =anglais() :
Option Explicit 'Déclaration des variables obligatoire
Function anglais(f)
anglais = f.Formula
End Function
* Date de la dernières sauvegarde :
En A1 : =DernièreSauvegarde()
Résultat en A1 => exemple : mercredi 20 janvier 2016
Function DernièreSauvegarde()
Application.Volatile
DernièreSauvegarde = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function
* Calculer le PRIX d'un produit en DEUXIEME DEMARQUE :
Programme de la fonction =CALCUL_DEUXIEME_DEMARQUE() :
Option Explicit 'Déclaration des variables obligatoire
Function CALCUL_DEUXIEME_DEMARQUE(PRIX_DE_VENTE, TAUX_Première_DEMARQUE, TAUX_Deuxième_DEMARQUE)
CALCUL_DEUXIEME_DEMARQUE = (PRIX_DE_VENTE - (PRIX_DE_VENTE * TAUX_Première_DEMARQUE / 100)) _
- ((PRIX_DE_VENTE - (PRIX_DE_VENTE * TAUX_Première_DEMARQUE / 100)) * TAUX_Deuxième_DEMARQUE / 100)
End Function
* SUPPRESSION DES BALISES HTML D'UNE CHAINE DE CARACTERES :
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function SupprimerHTML(ByVal strHTML As String) As String
Dim re As VBScript_RegExp_55.RegExp' Remplacement de certains caractères html
strHTML = Replace(strHTML, "é", "é")
strHTML = Replace(strHTML, "è", "è")
strHTML = Replace(strHTML, "à", "à")
strHTML = Replace(strHTML, " ", " ")
strHTML = Replace(strHTML, "’", "'")
strHTML = Replace(strHTML, "ô", "ô")' On crée une expression régulière
Set re = New RegExp ' On définit le critère qui cherche toute balise HTML
re.Pattern = "<\s*?[^>]+\s*?>"' On fait en sorte que la casse (majuscules/minuscules) soit indifférente
re.IgnoreCase = True ' Traitement global (récursif)
re.Global = True ' La fonction Test renvoie True si la chaîne respecte le critère
SupprimerHTML = re.Replace(strHTML, "")
End Function
et bien d'autres à venir......
* METTRE LE TEXTE EN MINUSCULE sauf après un POINT :
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
* METTRE LE TEXTE EN MINUSCULE sauf après un POINT :
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function Majuscule_après_point(phrase As String)
Dim temp
Dim i As Variant, t As String
temp = Split(phrase, ".")
For i = LBound(temp) To UBound(temp)
t = Trim(temp(i))
If i = 0 Then
Majuscule_après_point = UCase(Left(t, 1)) & LCase(Right(temp(i), Len(t) - 1))
Else
Majuscule_après_point = Majuscule_après_point & ". " & UCase(Left(t, 1)) & LCase(Right(t, Len(t) - 1))
End If
Next i
End Function
* EXTRACTION CHIFFRE avec ZERO :
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Dim temp
Dim i As Variant, t As String
temp = Split(phrase, ".")
For i = LBound(temp) To UBound(temp)
t = Trim(temp(i))
If i = 0 Then
Majuscule_après_point = UCase(Left(t, 1)) & LCase(Right(temp(i), Len(t) - 1))
Else
Majuscule_après_point = Majuscule_après_point & ". " & UCase(Left(t, 1)) & LCase(Right(t, Len(t) - 1))
End If
Next i
End Function
* EXTRACTION CHIFFRE avec ZERO :
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function Extraction_chiffre_avec_zéro(Cellule_Ref As Range, Nombre_chiffre As Byte)
Extraction_chiffre_avec_zéro = Left(Cellule_Ref, Nombre_chiffre)
End Function
* Tranformer une Durés en lettre en Durée en CHIFFRE :
(H2so4 sur Excel Pratique)
En A1 : 2 heures 16 minutes 11 secondes
En B1 : =txttotime(A1)
Résultat => 02:16:11
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
* Incrémenter un chiffre ou du texte alphanumérique en horizontal ou en vertical :
(Source H2so4 sur Excel Pratique)
En A1 : Version 1
En A2 : =add1tocell(A1)
Résultat => Version 2
Incrémenter vers le bas pour Version 3 et etc
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function add1tocell(r)
If Len(r) = 0 Then add1tocell = r: Exit Function
If IsNumeric(r) Or IsDate(r) Then add1tocell = r + 1: Exit Function
s = ""
Do
i = i + 1
If i > Len(r) Then add1tocell = r: Exit Function
Loop Until IsNumeric(Mid(r, i, 1))
While IsNumeric(Mid(r, i, 1)) And i <= Len(r)
s = s & Mid(r, i, 1)
i = i + 1
Wend
add1tocell = Replace(r, s, Val(s) + 1, Count:=1)
End Function
* Détecter si une cellule contient une date :
En A1 : 01/01/2022
En A2 : =ESTDATE (A1)
Résultat => VRAI
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function ESTDATE(CELLULE As Variant) As Boolean
Extraction_chiffre_avec_zéro = Left(Cellule_Ref, Nombre_chiffre)
End Function
* Tranformer une Durés en lettre en Durée en CHIFFRE :
(H2so4 sur Excel Pratique)
En A1 : 2 heures 16 minutes 11 secondes
En B1 : =txttotime(A1)
Résultat => 02:16:11
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Public Function TxtToTime(stime)
t = Split(stime, " ")
For i = LBound(t) To UBound(t)
Select Case UCase(Left(t(i), 4))
Case "HEUR", "HOUR"
h = t(i - 1) + 0
Case "MINU"
m = t(i - 1) + 0
Case "SECO"
s = t(i - 1) + 0
End Select
Next i
TxtToTime = TimeSerial(h, m, s)
End Function
* Incrémenter un chiffre ou du texte alphanumérique en horizontal ou en vertical :
(Source H2so4 sur Excel Pratique)
En A1 : Version 1
En A2 : =add1tocell(A1)
Résultat => Version 2
Incrémenter vers le bas pour Version 3 et etc
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function add1tocell(r)
If Len(r) = 0 Then add1tocell = r: Exit Function
If IsNumeric(r) Or IsDate(r) Then add1tocell = r + 1: Exit Function
s = ""
Do
i = i + 1
If i > Len(r) Then add1tocell = r: Exit Function
Loop Until IsNumeric(Mid(r, i, 1))
While IsNumeric(Mid(r, i, 1)) And i <= Len(r)
s = s & Mid(r, i, 1)
i = i + 1
Wend
add1tocell = Replace(r, s, Val(s) + 1, Count:=1)
End Function
* Détecter si une cellule contient une date :
En A1 : 01/01/2022
En A2 : =ESTDATE (A1)
Résultat => VRAI
Programme de la fonction
Option Explicit 'Déclaration des variables obligatoire
Function ESTDATE(CELLULE As Variant) As Boolean
On Error GoTo fin
x = CDate(CELLULE)
ESTDATE = True
On Error GoTo 0
Exit Function
fin:
ESTDATE = False
On Error GoTo 0
End Function
PERSONNALISER vos fonctions personnalisées en y indiquant vos remarques et directives :
Exemple de la fonction personnalisée HORS_TAXE sans personnalisation :
Dans le Projet - VBAProject cliquez sur ThisWorkbook et intégrer cette partie de programmation que nous allons alimenter en fonction des fonctions personnalisées du fichier.
Option Explicit
Private Sub Workbook_Open()
Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1 To 3) As String 'Variable pour le nombre d'arguments possibles dans les fonctions personnaliséée (peut être supérieur ou inférieur)
Application.MacroOptions Macro:=FuncName, Description:=FuncDesc, Category:=Category, ArgumentDescriptions:=ArgDesc
End Sub
Cette partie de programme permet de définir qu'à l'ouverture du fichier toutes les annotions de formules personnalisées mentionnées dans celui-ci permettra d'avoir une personnalisation de votre fenêtre d'ouverture de la fonction.
Donc pour exemple pour la fonction personnalisée HORS_TAXE insérer cette partie de programme qui lui est propre.
FuncName = "HORS_TAXE" 'Nom de la Fonction
FuncDesc = "Permet de calculer le montant Hors Taxe par rapport : " & vbCr & " * au montant TTC" & vbCr & " * au taux de TVA" 'Descriptif de la fonction
Category = 1 'Catérogie Fonctions Personnalisées - Dans ce cas le choix de 1 intègrera votre fonction personnalisée dans la catégorie finandes. En mettant 14 elle restera dans la catégorie "Personnalisée". (*)
ArgDesc(1) = " est votre montant TTC" 'Texte descriptif du 1er argument
ArgDesc(2) = " est votre taux de TVA" 'Texte descriptif du 2ème argument
En rouge les données que vous devez changer.
(*) Les diverses catégorie
1 Finances
2 Date et Heure
3 Math et Trigo
4 Statistiques
5 Recherche Matrices
6 Base de données
7 Texte
8 Logique
9 Informations
10 Commandes
11 Personnalisation
12 Contrôle de macros
13 DDE/Externe
14 Personnalisées
15 Ingénierie
16 Cube
Les catégories 10, 12 et 13 sont visibles uniquement si elles contiennent une fonction.
Donc voici votre fonction HORS_TAXE avec personnalisation (c'est un peu plus professionnel !!)
FuncName = "Nom de la Fonction"
FuncDesc = "Description de la fonction"
Category = Catérogie Fonctions Personnalisées 'en chiffre
ArgDesc(1) = "Descriptif du 1er argument"
ArgDesc(2) = "Descriptif du 2ème argument"
ArgDesc(3) = "Descriptif du 3ème argument" 'et (4) et à suivre si plus d'argument. N'oubliez pas de changer le variable ArgDesc en fonction du nombre maximum d'arguments
Ou une AUTRE SOLUTION de personnalisation reprenant en partie la solution précédente.
Private Sub auto_Open()
Application.MacroOptions _
Macro:="HORS_TAXE", _
Description:="Permet de calculer le montant Hors Taxe par rapport : " & vbCr & " * au montant TTC" & vbCr & " * au taux de TVA", _
Category:=1, _
ArgumentDescriptions:=Array(" est votre montant TTC", " est votre taux de TVA")
End Sub
Amusez-vous !
Rendre une fonction opérationnelle dès l'ouverture d'Excel et disponible sur tous les fichiers.
Attention : Une fonction est disponible uniquement lorsque le classeur qui contient la procédure est ouvert.
Vous devez créer un complément pour que votre fonction personnelle soit disponible dès l'ouverture de l'application.
Créez un nouveau classeur vierge.
Insérez un module standard depuis l'éditeur de macros.
Copiez-y les fonctions de votre choix.
Sauvegardez le fichier au format .xlam pour Excel2007 et .xla pour les versions antérieures d'Excel.
Vous remarquerez que la boîte de dialogue s'ouvre automatiquement sur le répertoire spécifique des macros complémentaires, lorsque vous choisissez ces types d'extension.
Ce chemin est généralement:
C:\Documents and Settings\nom_utilisateur\Application Data\Microsoft\Macros complémentaires (ou AddIns)
Nommez votre complément.
Cliquez sur le bouton OK pour valider.
Pour activer la macro complémentaire (avant Excel2007):
Menu Outils
Macros complémentaires
Si vous avez bien enregistré le classeur dans le répertoire spécifique des macros complémentaires, votre fichier doit apparaitre dans la boîte de dialogue qui s'affiche à l'écran (Cliquez sur le bouton "Parcourir" si votre complément n'apparait pas dans la liste).
Sous Excel2007:
Cliquez sur le bouton "Office".
Cliquez sur le bouton "Options Excel".
Sélectionnez le menu Compléments.
Choisissez "Compléments Excel" dans le menu déroulant "Gérer" (en bas de la fenêtre).
Cliquez sur le bouton "Atteindre"
Sous Excel 2013 :
Cliquez sur Fichiers
Cliquez sur Options
Cliquez sur Compléments
Choisissez "Compléments Excel" dans le menu déroulant "Gérer" (en bas de la fenêtre).
Cliquez sur le bouton "Atteindre"
Aucun commentaire :
Enregistrer un commentaire
Pour vous aider à publier votre commentaire, voici la marche à suivre :
1) Ecrivez votre texte dans le formulaire de saisie ci-dessus
2) Si vous avez un compte, vous pouvez vous identifier dans la liste déroulante Commentaire
Sinon, vous pouvez saisir votre nom ou pseudo par Nom/URL
3) Vous pouvez, en cliquant sur le lien S'abonner par e-mail, être assuré d'être avisé en cas d'une réponse
4) Cliquer sur Publier enfin.
Le message sera publié après modération.
Merci