Rechercher dans ce blog

Nombre total de pages vues

VBA - CREATION DE FONCTIONS PERSONNALISEES









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, 11, 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
    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 
 
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


* 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 D :  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
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
* 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 

* Compter le nombre de cellule de même couleur dans une plage de cellules :
Option Explicit

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 :  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 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


* 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...............

    Programme de la fonction =Remplissage() :
    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

    Programme de la fonction =anglais() :    Option Explicit 'Déclaration des variables obligatoire
    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, "&eacute;", "é")
strHTML = Replace(strHTML, "&egrave;", "è")
strHTML = Replace(strHTML, "&agrave;", "à")
strHTML = Replace(strHTML, "&nbsp;", " ")
strHTML = Replace(strHTML, "&rsquo;", "'")
strHTML = Replace(strHTML, "&ocirc;", "ô")
' 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
  
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
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


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 :

et ci-après la fonction SI intégrée dans Exel avec sa propre personnalisation
Donc pour ma part je procède de la manière suivante, c'est-à-dire que le lance cette personnalisation de toutes mes fonctions personnalisées à l'ouverture du fichier.

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 !!)

 Maintenant si vous voulez paramétrer une autre fonction insérez ce code et complétez en fonction de vos choix

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