Accueil

 

ProcedureSansParametre Procédure avec paramètre Les fonctions personnalisées Descriptif fonction personnalisée Appel d'un autre classeur XLStart IsAddin Exemples Fonction matricielle Fonction retournant un type défini

Liste des modules et procédures Activation d'une procédure à partir d'une liste

Sub Call ByRef-ByVal Function IsAddin Run Optional Caller Parent Auto_Open

Procédures sans paramètre

La syntaxe d’une procédure est la suivante :

Sub Nom_procédure(Paramètre1,paramètre2,...)
   ......
   ......
End Sub

Une procédure peut en appeler une autre. Sur cet exemple, la procédure BAS déplace le
curseur vers le bas.

Sub proc1()
  Range("a1").Select
  ActiveCell.Value= "coucou"
  Bas                                              ' Appel de la procédure Bas
  ActiveCell.Value = "coucou"
End Sub

Sub Bas()
   ActiveCell.Offset(1, 0).Select         ' Descend le curseur d’une ligne
End Sub

Appel de procédure avec paramètres

Sur cet exemple, la procédure Décale(lig,col) déplace le curseur du nombre de lignes et
de colonnes spécifiés.
Lors de l’appel de la procédure decale 3,1:

• La valeur 3 est transmise dans le paramètre lig
• La valeur 1 est transmise dans le paramètre col

Sub essai()
  Range("a1").Select
  ActiveCell.Value = "Début"
  decale 3, 1           ' 3lignes, 1 colonne
  ActiveCell.Value = "Essai"
End Sub

Sub decale(lig, col)
  ActiveCell.Offset(lig, col).Select
End Sub

Autre syntaxe : Call nom_procédure(param1,param2,…):

Sub essai()
  Range("a1").Select
  ActiveCell.Value = "Début"
  Call decale(3, 1) ' 3lignes, 1 colonne
  ActiveCell.Value = "Essai"
End Sub

Appel d’une procédure dans un autre classeur

Sub essai()
  Application.Run "MesProcédures.xls!proc1"       ' appel procédure
End Sub

Byref Byval

L’options Byref et Byval permettent de spécifier si le passage se fait par valeur ou par adresse. L’option par défaut est ByRef.
Sur l’exemple, p=456 modifie la valeur de la variable a.

Sub essai(ByRef p)
  p = 456
End Sub

Sub essai1()
  Dim a
  a = 123
  Call essai(a)
  Msgbox a
End Sub

Les fonctions

Contrairement à une procédure, une fonction retourne un résultat. L'option As type permet
de spécifier le type de la valeur retournée.

La syntaxe est la suivante :

Function nom_fonction(paramètre1, paramètre2,,....) AS type
   instruction1
   instruction2
   ............
   nom_fonction=valeur_retour
End Function

Sur l'exemple, Lors de l'appel de la fonction, le paramètre DateNaissance de la fonction Age(DateNaissance) est remplacé par la valeur 13/12/1960.

Le résultat doit être retourné dans Age, c'est à dire le nom de la fonction.

Function Age(DateNaissance)
   Age=Year(Date)-Year(DateNaissance)
End Function

Dans le tableur:

=Age(A1)          ' A1 contient la date de naissance

On peut utiliser Insertion/Fonction/personnalisées pour créer la formule.

En VBA:

Sub Essai()
   d = #10/12/1980#
   MsgBox Age(d)
End Sub

Une fonction écrite dans un module est utilisable dans tout le classeur.

Appel d’une procédure ou fonction dans un autre classeur

Appel d'une fonction à partir du tableur

=XX.XLS!age(A1)

Appel d'une procédure ou fonction à partir de VBA

Une procédure ou fonction d'un autre classeur se fait avec:

Run Procédure,param1,param2,..
résult=Run(fonction,param1,param2,..)

Run "MesProc.xls!proc1", 11                                     ' appel procédure
result = Run("MesFonctions.xls!age", #1/1/1980#)     ' appel fonction

L'opérateur saisit 1,2,3,4 dans la cellule A1

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, [A1]) Is Nothing And Target.Count = 1 Then
     Run Array("macro1", "macro2", "macro3", "macro4")(Target - 1)
  End If
End Sub

ou

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, [A1]) Is Nothing And Target.Count = 1 Then Run "macro" & Target
End Sub

Xlstart

Si un classeur est placé dans le répertoire XLStart, il est ouvert automatiquement.

C:\Documents and Settings\jboisgon\Application Data\Microsoft\Excel\XLSTART

(Ce classeur peut être Perso.xls)

-Insertion/Fonctions/Catégorie personnalisées donne accés aux fonctions persos

- Si la propriété Isaddin de ThisWorkBook a été cochée, l’appel des fonctions se fait alors
sans le nom du classeur devant le nom de la fonction:
=Age(A1) au lieu de =XX.XLS!age(A1).

Macro complémentaire

En enregistrant MesFonctions.Xls sous forme de Macro complémentaire, on obtient un fichier MesFonctions.Xla (dans le répertoire MacroComplémentaires).
En cochant Outils/Macros complémentaires/Mesfonctions.xla, on a alors accés (sur son poste et dans le tableur) aux fonctions à partir de tous les classeurs. Mais, pour un autre poste, il faut installer la macro complémentaire et la cocher avec Outils/Macro complémentaire.

Appel d'une fonction d'une macro complémentaire

Function age(dn)
   age = Year(Date) - Year(dn)
End Function

Sub essai()
  dateNaiss = #1/1/2000#
  mAge = Application.Run("age", dateNaiss) ' appel
  MsgBox mAge
End Sub

Appel d'une procédure d'une macro complémentaire

Sub affiche(m)
  MsgBox m
End Sub

Sub essai2()
   Application.Run "affiche", "essai" ' appel
End Sub

Descriptif de fonction personnalisée

L'utilisation de Fx donne un descriptif des fonctions personnalisées

Private Sub auto_Open()
  Application.MacroOptions Macro:="SommeCouleurFond", _
  Description:="Donne la somme des nombres des cellules ayant la couleur spécifiée", Category:=14
End Sub

Exemples de fonctions

Suppression d’accents

Function sansAccent(chaine)
  codeA = "éèêëàçùôûïî"
  codeB = "eeeeacuouii"
  temp = chaine
  For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
  Next
  sansAccent = temp
End Function

Extraction du nom et du prénom

Function Nom(chaine)
  Application.Volatile
  a = Split(chaine, " ")
  i = UBound(a)
  Do While UCase(a(i)) = a(i) And i > LBound(a): i = i - 1: Loop
  For k = i + 1 To UBound(a): temp = temp & a(k) & " ": Next
  Nom = Trim(temp)
End Function

Function PreNom(chaine)
  Application.Volatile
  a = Split(chaine, " ")
  i = UBound(a)
  Do While UCase(a(i)) = a(i) And i > LBound(a): i = i - 1: Loop
  For k = LBound(a) To i: temp = temp & a(k) & " ": Next
  PreNom = Trim(temp)
End Function

Inversion du nom et du prénom

Function InverseNP(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
  InverseNP = Trim(temp)
End Function

Nom du classeur actif

Function NomClasseur() As String
Application.Volatile
NomClasseur = ActiveWorkbook.Name
End Function

Traduction formule en anglais

Function anglais(f)
anglais = f.Formula
End Function

Somme des cellules visibles

Calcule la somme des cellules visibles.

Function SommeVisibles(champ As Range)
  Application.Volatile
  t = 0
  For Each c In champ
    If Not c.EntireRow.Hidden And Not c.EntireColumn.Hidden Then
       t = t + c.Value
    End If
  Next c
  SommeVisibles = t
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
calcultate
End Sub

Extraction d’un nombre d’une chaîne

Function NumChaine(chaine)
  temp = ""
  For i = 1 To Len(chaine)
    c = Mid(chaine, i, 1)
    If c >= "0" And c <= "9" Then temp = temp & c
  Next i
  NumChaine = temp
End Function

Function NumChainePremOccur(chaine)
  longueur = Len(chaine)
  temp = ""
  p = 1
  Do While Not IsNumeric(Mid(chaine, p, 1)) And p <= longueur
    p = p + 1
  Loop
  Do While IsNumeric(Mid(chaine, p, 1)) And p <= longueur
    temp = temp & Mid(chaine, p, 1)
    p = p + 1
  Loop
  NumChainePremOccur = temp
End Function

Function NumChaineOccur(chaine, occurence)
  longueur = Len(chaine)
  p = 1
  occur = 0
  Do
     temp = ""
     Do While Not IsNumeric(Mid(chaine, p, 1)) And p <= longueur
        p = p + 1
     Loop
     Do While IsNumeric(Mid(chaine, p, 1)) And p <= longueur
        temp = temp & Mid(chaine, p, 1)
        p = p + 1
     Loop
    occur = occur + 1
  Loop Until occur = occurence
  NumChaineOccur = temp
End Function

Function NumChaineDernOccur(chaine)
  longueur = Len(chaine)
  temp = ""
  p = longueur
  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
   NumChaineDernOccur = temp
End Function

Date de sauvegarde d'un classeur

Function DernièreSauvegarde()
   Application.Volatile
   DernièreSauvegarde() = ThisWorkbook.BuiltinDocumentProperties("Last Save Time")
End Function

Compte les cellules par couleur

La fonction ci dessous compte les cellules ayant la m^me couleur que la couleur témoin.

- FonctionCompteCouleur -

Function CompteCouleurFond(champ As Range, couleurTémoin As Range)
  Application.Volatile
  Dim c, temp
  temp = 0
  For Each c In champ
    If c.Interior.Color = couleurTémoin.Interior.Color Then
      temp = temp + 1
    End If
  Next c
  CompteCouleurFond = temp
End Function

Pour que la mise à jour des fonctions soit automatique lorsque l'on modifie la couleur, ajouter dans le code la feuille:

Dim celluleAvant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not IsEmpty(celluleAvant) Then
    If Not Intersect(Range(celluleAvant), [B2:B1000]) Is Nothing Then Calculate
  End If
  celluleAvant = Target.Address
End Sub

Fonction matricielle renvoyant un tableau

Sur cet exemple, la fonction matricielle retourne une liste de noms sans doublons.

Function SansDoublons(champ As Range)
  Set MonDico = CreateObject("Scripting.Dictionary")
  temp = champ
  For i = 1 To UBound(temp, 1)
    If Not MonDico.Exists(temp(i, 1)) Then MonDico.Add temp(i, 1), temp(i, 1)
  Next i
  SansDoublons = Application.Transpose(MonDico.items)
End Function

Utlisation dans le tableur

• Sélectionner le champ D2 :D10
• =sansdoublons(A2:A30)
• Valider avec Maj+Ctrl+Entrée

Si on veut obtenir une liste horizontale:=TRANSPOSE(sansdoublons(A2:A7))

Pour éviter #N/A

Application.Caller.Rows.count donne le nombre de cellules sélectionnées pour l'appel de la fonction matricielle.

Function SansDoublons2(champ As Range)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In champ
    If Not mondico.Exists(c.Value) And c.Value <> "" Then mondico.Add c.Value, c.Value
  Next c
  Dim temp()
  ReDim temp(1 To Application.Caller.Rows.Count)
  i = 1
  For Each c In mondico.items
    temp(i) = c
    i = i + 1
   Next
  SansDoublons2 = Application.Transpose(temp)
End Function

Utilisation d’une fonction matricielle à partir de VBA

Sur cet exemple, nous obtenons les éléments communs de 2 listes

Function InterSection(a As Range, b As Range)
   Dim temp()
   k = 0
   For i = 1 To a.Count
      For j = 1 To b.Count
        If a(i) = b(j) And a(i) <> "" And b(j) <> "" Then
           ReDim Preserve temp(0 To k)
           temp(k) = a(i)
           k = k + 1
        End If
     Next j
  Next i
  InterSection = Application.Transpose(temp)
End Function

Utilisation à partir de VBA

Sub RecupFonctionMatricielle()
   a = InterSection([A2:A10], [B2:B10])
   i = 1
   Do While i <= UBound(a)
      UserForm1.ListBox1.AddItem a(i, 1)
      i = i + 1
   Loop
   UserForm1.Show
End Sub

ou

Sub RecupFonctionMatricielle2()
   i = 1
   Do While i <= UBound(InterSection([A2:A10], [B2:B10]))
      UserForm1.ListBox1.AddItem InterSection([A2:A10], [B2:B10])(i, 1)
      i = i + 1
   Loop
   UserForm1.Show
End Sub

Fusion de 2 listes

Function Fusion(a As Range, b As Range)
  Dim temp()
  k = 0
  For i = 1 To a.Count
    If a(i) <> "" Then
       ReDim Preserve temp(0 To k)
       temp(k) = a(i)
       k = k + 1
    End If
   Next i
   For i = 1 To b.Count
     If IsError(Application.Match(b(i), a, 0)) And b(i) <> "" Then
        ReDim Preserve temp(k)
        temp(k) = b(i)
        k = k + 1
     End If
     Next i
     Fusion = Application.Transpose(temp)
End Function

Fonction retournant un type défini

Sur cet exemple, la fonction retourne une valeur d'un type défini: une chaîne + un booléen

Type Retour
  Chaine As String
  VraiFaux As Boolean
End Type

Sub Essai()
   Dim a As String
   Dim b As Retour
   a = "abcde"
   b = maFonction(a)
   y = b.chaine
   z = b.VraiFaux
End Sub

Function maFonction(p As String) As Retour
   Dim temp As Retour
   temp.chaine = UCase(p)
   temp.VraiFaux = IsNumeric(p)
   maFonction = temp
End Function

Paramètre Optional

Optional permet de définir un paramètre optionnel.

Function RangSansDoublons(n, champ, Optional ordre)
  Application.Volatile
  If IsMissing(ordre) Then ordre = 0
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In champ
     If Not mondico.Exists(c.Value) Then mondico.Add c.Value, c.Value
  Next c
  t = 0
  For Each c In mondico.items
    Select Case ordre
      Case 0
        If c > n Then t = t + 1
      Case 1
        If c < n Then t = t + 1
    End Select
  Next c
  RangSansDoublons = t + 1
End Function

Caller

Caller permet d'accéder à l'adresse de la cellule où la fonction est écrite

-Caller Couleur -

Donne la couleur de fond de la cellule appelante

Function couleurFond()
  Application.Volatile
  couleurFond = Range(Application.Caller.Address).Interior.ColorIndex
End Function

Modifie le texte de la cellule appelante en fonction de sa couleur

Function couleurFondTexte()
  Application.Volatile
  Select Case Range(Application.Caller.Address).Interior.ColorIndex
    Case 3
       couleurFondTexte = "Rouge"
    Case 4
       couleurFondTexte = "Vert"
    Case 6
        couleurFondTexte = "Jaune"
    Case Else
        couleurFondTexte = "JeSaisPas"
   End Select
End Function

Pour Maj si modification couleur:

Dim celluleAvant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not IsEmpty(celluleAvant) Then
     If Not Intersect(Range(celluleAvant), [B:B]) Is Nothing Then Calculate
  End If
  celluleAvant = Target.Address
End Sub

Nom du shape appellant

Le programme ci dessous modifie l'aspect du texte du bouton appelant. Application.Caller donne le nom du bouton qui a déclenché la macro.

NomShape = Application.Caller
ActiveSheet.Shapes(NomShape).TextFrame.Characters(Start:=1, Length:=15).Font.Bold = _
Not ActiveSheet.Shapes(NomShape).TextFrame.Characters(Start:=1, Length:=1).Font.Bold

Parent

Utilisé dans une fonction , Parent donne le nom de la feuille où la fonction est appellée

NomFeuille = Application.Caller.parent.Name

Fonction renvoyant le nom de la feuille

Function NomFeuille()
  Application.Volatile
  NomFeuille = Application.Caller.Parent.Name
End Function

auto_open/auto_close()

La macro nommée auto_open() dans un module est exécutée automatiquement à
l'ouverture du classeur.
Contrairement à WorkBook_Open() , elle n'est pas exécutée si le classeur est ouvert par
programme.
Pour empêcher la macro auto_open d'être exécutée à l'ouverture d'un classeur, appuyer sur
la touche Majuscules.
La macro auto_close() est exécutée à la fermeture d'un classeur.

Exemples

Liste des modules et procédures

Donne la liste des modules et procédures du classeur.

ListeProc

Module1
  essai
  essai2
Module2
  Essai3

i = 1
For Each c In ActiveWorkbook.VBProject.VBComponents
  If c.Type = 1 Then
    Cells(i, 1) = c.CodeModule.Name
    i = i + 1
    For ligne = 1 To c.CodeModule.CountOfLines
       temp = Trim(c.CodeModule.Lines(ligne, 1))
       If Left(temp, 3) = "Sub" Then
         Cells(i, 1) = Mid(Left(temp, Len(temp) - 2), 4)
         i = i + 1
       End If
    Next ligne
  End If
Next c

Activation d'une procédure à partir d'une liste déroulante

Sur cet exemple, l'opérateur choisit dans une liste dérouante la procédure à activer.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    Application.Run Target.Value
  End If
End Sub

Function ListeSub()
  ' Outils/Macros/Sécurité/Sources fiables/Cocher Faire confiance au projet Visual Basic
  Dim Retour()
  n = 0
  For Each c In ActiveWorkbook.VBProject.VBComponents
    For ligne = 1 To c.CodeModule.CountOfLines
      temp = Trim(c.CodeModule.Lines(ligne, 1))
      If Left(temp, 3) = "Sub" Then
         n = n + 1
         ReDim Preserve Retour(1 To n)
         Retour(n) = Mid(Left(temp, Len(temp) - 2), 4)
      End If
    Next
  Next
  ListeSub = Application.Transpose(Retour)
End Function

Variante dans un formulaire

La liste des procédures est affiché dans un formulaire non modal.

- ActiveSub -

Private Sub UserForm_Initialize()
' Outils/Macros/Sécurité/Sources fiables/Cocher Faire confiance au projet Visual Basic
  For Each c In ActiveWorkbook.VBProject.VBComponents
    For ligne = 1 To c.CodeModule.CountOfLines
      temp = Trim(c.CodeModule.Lines(ligne, 1))
      If Left(temp, 3) = "Sub" Then Me.ComboBox1.AddItem Mid(Left(temp, Len(temp) - 2), 4)
    Next
  Next
End Sub

Private Sub ComboBox1_Change()
   Application.Run Me.ComboBox1
End Sub

Private Sub Workbook_Open()
   UserForm1.Show
End Sub