Quelques procédures VBA

Préambule : Je décline toute responsabilité si l'une de ces procédures ne fonctionnait pas…

En revanche, je m'engage à les corriger ou apporter des commentaires si vous me signalez une anomalie…

Bien entendu, toutes ces procédures sont à adapter en fonction de votre besoin…

N'hésitez pas à me signaler les anomalies, améliorations à apporter…

All these procedures are to be adapted according to your need ...

Please notify me of anomalies, improvements ..

Références Manquantes

Préambule :
Cette notion de références manquantes existe lorsque l'on a programmé avec l'idée d'avoir l'aide à la saisie de VBA Excel.
Exemple de code entre Access et Excel :
=======================================
Dim objXL As Excel.Application
Dim oSheetEP As Excel.Worksheet
Dim oCellEP As Excel.Range
Set objXL = New Excel.Application
=======================================
Cette façon de procéder est pratique car VBA va proposer les méthodes/Propriétés liées à l'objet saisi, mais est contraignante dès lors qu'on souhaite utiliser l'application sur des versions antérieures

Pour remédier à ce problèmes, nous allons pouvoir (sans les références à Excel), déclarer les variables en tant qu'objet...
=======================================
Dim objXL As Object
Dim oSheetEP As Object
Dim oCellEP As Object
Set objXL = GetObject(, "Excel.Application") 's'il s'agit d'ouvrir une session active d'Excel
ou
Set objXL = CreateObject("Excel.Application") 's'il s'agit de créer une nouvelle session Excel
========================================
Et la suite se programmera de la même façon, sans l'aide VBA à la saisie.

Rien n'empêche de faire le programme avec les référence, et ensuite supprimer les références, les déclarations de variables, et les lignes "Set etc..."

Si vous n'avez pas d'autres choix que de conserver les références (Pour quelles raisons ?) la suite sera alors utile.

J'ai longtemps cherché la solution à ce problème : dans une application Excel, on fait appel à Word, ce qui nécessite d'ajouter la bibliothèque Microsoft Word X Office Library (Menu Outils Références de l'éditeur Visual Basic)

Si l'application est destinée à "voyager", elle peut passer d'une version Excel à une autre, et en cas de retour à une version inférieure, Excel ne parvient plus à trouver la référence Word correspondante. Bien sur, il suffit d'aller dans l'éditeur Visual Basic et de corriger dans le menu Outils Références, mais si on souhaite le faire sans intervention de l'utilisateur, c'est un peu plus compliqué.

En effet, il semble impossible de "décocher" par code une référence manquante (malgré certaines procédures trouvées ici et là, toutes basées sur la théorie, mais ne fonctionnant pas en réalité)

Voici la solution que j'ai adoptée :
1 – Ne pas cocher la référence dans "l'application Excel"
2 – Cocher la référence par code VBA au moment où on en a besoin.
3 – Décocher après l'utilisation de Word dans Excel

Pour la recherche de l'endroit où se trouve la Bibliothèque référence à Word, je me suis inspiré du code trouvé sur le site de Frédéric SIGONNEAU (Merci à lui et à Michel PERRON qui m'a mis sur la bonne piste)
Première étape : Partie du code à recopier de préférence dans un module dédié

Cette première étape contient les procédures de suppression d'une référence, d'ajout d'une référence, de recherche d'une référence Word sur l'environnement utilisateur

Option Explicit
'recherche de fichiers avec les fonctions API (rapide, récursif)
'code à étudier :-)
Private Const vbDot = 46
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"
Private fp As FILE_PARAMS 
Private List1(1000, 0) As String
Private i As Long
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Private Type FILE_PARAMS
  bRecurse As Boolean
  bFindOrExclude As Long
  '1=find matching, 0=exclude matching
  nCount As Long
  nSearched As Long
  sFileNameExt As String
  sFileRoot As String
End Type

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" Alias "PathMatchSpecW" (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long
Declare Function DllRegisterServer Lib "Word.Olb" () As Long

Sub SupprimerReference()
  Dim LesRef As Object
  For Each LesRef In ActiveWorkbook.VBProject.References
    If Len(LesRef.GUID) > 0 Then
      'On Error Resume Next
      If UCase(LesRef.Name) = "WORD" Then
        ActiveWorkbook.VBProject.References.Remove LesRef
        Exit For
      End If
    End If
  Next

  Application.StatusBar = False
End Sub

Sub StartSearch()
  Dim hFile As Long
  Dim WFD As WIN32_FIND_DATA
  Dim FolderName As String
  Dim FileName As String
  Dim n As Long
  Application.StatusBar = "Recherche Référence Word"
  Dim Message, Title, Default
  FolderName = Application.Path
  Dim Message2, Title2, Default2
  FileName = "MSWORD*.OLB"
  i = 0
  Erase List1
  With fp
    .sFileRoot = QualifyPath(FolderName)
    .'start path
    .sFileNameExt = FileName
    'file type(s) of interest
    .bRecurse = True
    'True = recursive search
    .nCount = 0
    'results
    .nSearched = 0
    'results
    .bFindOrExclude = 1
    '1 = find, 0 = exclude
  End With
  Call SearchForFiles(fp.sFileRoot)
  If i = 0 Then
    'MSWORD*.OLB pas trouvé dans le dossier d'installation d'Office
    'rechercher dans un dossier Parent
    If UCase(VBA.Left(FolderName, 17)) = "C:\PROGRAM FILES\" Then
      FolderName = "C:\Program Files\"
    Else
      Dim NbAntiS As Integer
      NbAntiS = 0
      For i = 1 To Len(FolderName)
        If VBA.Mid(FolderName, i, 1) = "\" Then
          NbAntiS = NbAntiS + 1
        End If
      Next
      If NbAntiS = 2 Then
        FolderName = VBA.Left(FolderName, 3)
      Else
        NbAntiS = 0
        For i = 1 To Len(FolderName)
          If VBA.Mid(FolderName, i, 1) = "\" Then
            NbAntiS = NbAntiS + 1
            If NbAntiS = 2 Then
              FolderName = VBA.Left(FolderName, i)
              Exit For
            End If
          End If
        Next
      End If
    End If
    i = 0
    With fp
      .sFileRoot = QualifyPath(FolderName)
      'start path
      .sFileNameExt = FileName
        'file type(s) of interest
        .bRecurse = True
        'True = recursive search
        .nCount = 0
        'results
        .nSearched = 0
        'results
        .bFindOrExclude = 1
        '1 = find, 0 = exclude
      End With
      Call SearchForFiles(fp.sFileRoot)
      If i = 0 Then
      'Toujours pas trouvé Word !!!!
      AfficheMessage APP_NAME & " n'a pas trouvé la référence à word dans votre environnement" & VBA.Chr(10) & "Vous allez devoir nous montrer le chemin..."
      FolderName = Application.GetOpenFilename(, , "Mais où est installé Word ?")
      NbAntiS = 0
      For i = 1 To Len(FolderName)
        If VBA.Mid(FolderName, i, 1) = "\" Then
          NbAntiS = NbAntiS + 1
        End If
      Next
      Dim NbRetenu As Integer
      NbRetenu = 0
      For i = 1 To Len(FolderName)
        If VBA.Mid(FolderName, i, 1) = "\" Then
          NbRetenu = NbRetenu + 1
          If NbRetenu = NbAntiS Then
            Exit For
          End If
        End If
      Next
      FolderName = VBA.Left(FolderName, i)
      With fp
        .sFileRoot = QualifyPath(FolderName)
        'start path
        .sFileNameExt = FileName
        'file type(s) of interest
        .bRecurse = True
        'True = recursive search
        .nCount = 0
        'results
        .nSearched = 0
        'results
        .bFindOrExclude = 1
        '1 = find, 0 = exclude
      End With
      Call SearchForFiles(fp.sFileRoot)
    End If
  End If
  Application.StatusBar = False
End Sub

Private Sub SearchForFiles(sRoot As String)
   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
   If hFile <> INVALID_HANDLE_VALUE Then
    Do
      Application.StatusBar = "Recherche Word : " & sRoot & TrimNull(WFD.cFileName)
      If (WFD.dwFileAttributes And vbDirectory) Then
        If Asc(WFD.cFileName) <> vbDot Then
          If fp.bRecurse Then
            SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
          End If
        End If
      Else
      'must be a file and not the open temp file (~$....)
      fp.nCount = fp.nCount + 1
      List1(i, 0) = sRoot & TrimNull(WFD.cFileName)
      i = i + 1
      Exit Do
      End If
     End If
    Loop While FindNextFile(hFile, WFD)
  End If
  Call FindClose(hFile)
End Sub

Private Function QualifyPath(sPath As String) As String
  If VBA.Right$(sPath, 1) <> vbBackslash Then
    QualifyPath = sPath & vbBackslash
  Else
      QualifyPath = sPath
End If
End Function

Private Function TrimNull(startstr As String) As String
  TrimNull = VBA.Left$(startstr, lstrlen(StrPtr(startstr)))
End Function

Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
  MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = fp.bFindOrExclude
End Function

========================================
Seconde étape : Cocher la référence à Word avant la déclaration de l'objet "Word.Application" Ceci ne peut pas se faire dans la même procédure, sous peine d'avoir une erreur d'exécution.
En supposant que l'utilisation de Word se fasse dans la procédure "ImprimeConditions", inscrire dans une procédure appelante :
StartSearch
'Coche la référence à Word
ImprimeConditions
  ThisWorkbook.VBProject.References.Remove
  ThisWorkbook.VBProject.References("Word")
  'Décoche la référence à Word
  Sub ImprimeConditions()
  Dim oWord As Object
  Set oWord = CreateObject("Word.Application")
  sFile = ActiveWorkbook.Path & "\Conditions.doc"
  If Dir(sFile) = "" Then
    AfficheMessage "Excel n'a pas trouvé le document" & VBA.Chr(10) & VBA.Chr(10) & "Conditions.doc" & VBA.Chr(10) & VBA.Chr(10) & "Qui devrait se trouver dans le même dossier que ce classeur" & VBA.Chr(10) &
    VBA.Chr(10) & "Les conditions spécifiques ne vont pas être imprimées"
    Set oWord = Nothing
    Exit Sub
  End If
  With oWord
    .DisplayAlerts = False
  .documents.Open FileName:=sFile, confirmconversions:=False, ReadOnly:=False, addtorecentfiles:=False, passworddocument:=APP_PASSWORD, passwordtemplate:="", revert:=False, writepassworddocument:=APP_PASSWORD, writepasswordtemplate:=""
    .Selection.endkey unit:=wdstory
    .Selection.typetext Text:="Page " &
    TotalPages & "/" & TotalPages
    .Selection.homekey unit:=wdstory
    .activedocument.PrintOut
    .activedocument.Close False
  End With
  'Une petite tempo pour laisser le temps d'imprimer
  NvlleHeure = Hour(Now())
  NvlleMinute = Minute(Now())
  NvlleSeconde = Second(Now()) + 15
  waitTime = TimeSerial(NvlleHeure, NvlleMinute, NvlleSeconde)
  Application.Wait waitTime
  oWord.Quit
  Set oWord = Nothing
End sub

Retour à la liste

Ajouter une case à cocher

Tout d'abord, des cases à cocher simple, avec cellule liée (non obligatoire)
Pour tester de façon simple :

Sub CaseACreer()
  AjoutCaseACocher Range("A1"), 0, 0, "Coucou", Range("B1")
End Sub

Sub AjoutCaseACocher(ByVal oCellS As Range, DecalH As Integer, DecalV As Integer, sTexte As String, oCellLiee As Range)
'oCellS : Cellule qui va recevoir la case
'DecalH : Décalage horizontal à l'intérieur de la cellule (en point)
'DecalV : Décalage vertical à l'intérieur de la cellule (en point)
'sTexte : le texte à associé à la case
'oCellLiee si vous souhaitez liée une cellule à la case…
'attention, les cases ne se positionnent correctement
'que sur un ZOOM 100%
'Prévoir de remettre le zoom à son état initial
'après la création des cases
  Dim LeZoom As Single
  LeZoom = ActiveWindow.Zoom
  ActiveWindow.Zoom = 100
  ActiveSheet.CheckBoxes.Add(oCellS.Left + DecalH, oCellS.Top + DecalV, 60, 17.25).Select
  With Selection
    .Text = sTexte
    .Value = xlOff
    .LinkedCell = oCellLiee.Address
    .Display3DShading = True
  End With
  ActiveCell.Select
  ActiveWindow.Zoom = LeZoom
End Sub

Un tout petit peu plus compliqué : Cases "journées" : les cellules liées étant sur
la même ligne que les cases, en colonne Q, R, S etc…

Sub AjoutCasesCalendar()
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 5, 0, "Lundi", Cells(ActiveCell.Row, 17)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 55, 0, "Mardi", Cells(ActiveCell.Row, 18)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 105, 0, "Mercredi", Cells(ActiveCell.Row, 19)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 155, 0, "Jeudi", Cells(ActiveCell.Row, 20)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 205, 0, "Vendredi", Cells(ActiveCell.Row, 21)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 255, 0, "Samedi", Cells(ActiveCell.Row, 22)
  AjoutCaseACocher Cells(ActiveCell.Row, 5), 305, 0, "Dimanche", Cells(ActiveCell.Row, 23)
End Sub

Puis des cases à cocher associées à une macro…
Option Explicit
Sub AjoutCasesInterdireAppel()
'Ajouter les cases à cocher "Interdire les appels ..."
  Dim i As Integer
'commençons par supprimer toutes les cases à cochées
'précédemment créées
  Dim LaCase As Shape
  For Each LaCase In ActiveSheet.Shapes
    If Left(LaCase.Name, 5) = "CAC00" Then
      LaCase.Delete
    End If
  Next
  For i = 0 To 4
    ActiveSheet.CheckBoxes.Add(ActiveCell.Left + i * 80, ActiveCell.Top, 80, 2).Select
    With Selection
      .Text = "Non"
      .Value = xlOff
      .LinkedCell = Cells(ActiveCell.Row, ActiveCell.Column + 8 + i).AddressLocal
      .Display3DShading = True
      .OnAction = "MacroPourCaseInt"
      .Name = "CAC00" & i
    End With
    ActiveCell.Select
  Next
End Sub

'La macro en question…

Sub MacroPourCaseInt()
  Dim MonObjet As String
  MonObjet = Application.Caller
  Dim iLigne As Long
  Dim iCol As Integer
  If ActiveSheet.CheckBoxes(MonObjet).Value = xlOn Then
    ActiveSheet.CheckBoxes(MonObjet).Text = "Oui"
  Else
    ActiveSheet.CheckBoxes(MonObjet).Text = "Non"
  End If
  iLigne = ActiveSheet.Shapes(MonObjet).TopLeftCell.Row
  iCol = ActiveSheet.Shapes(MonObjet).TopLeftCell.Column
  Cells(iLigne, iCol).Select
End Sub

Un danger subsiste… après de nombreuses exécutions de la macro.Après création au total de 65536 cases à cocher, VBA plante (même si vous avez fermé le classeur entre temps !)Voici la solution (que je connais) pour remédier à ce problème…
Insérez les lignes suivantes en début de procédure…

  Sheets("MaFeuille").Select
  Sheets("MaFeuille").Copy Before:=Sheets("MaFeuille")
  Application.DisplayAlerts = False
  Sheets("MaFeuille").Delete
ActiveSheet.Name = " MaFeuille"
Application.DisplayAlerts = True
Attention tout de même, car là aussi, Excel peut faire des siennes, si vous "abusez" de cette procédure au cours de la même session de votre classeur.
En effet, la répétition de cette procédure entraîne un "plantage" car Excel ne parvient plus à copier une feuille…
Si c'est la cas, préférez les lignes suivantes aux 6 décrites précédemment :

Dim oClassAct as Workbook
Dim oClassSource as Workbook
Set oClassAct = ActiveWorkbook
Workbooks.Add
Set oClassSource = ActiveWorkbook
Application.DisplayAlerts = False
If Worksheets.Count > 1 Then
  For i = Worksheets.Count To 2 Step -1
    Worksheets(i).Delete
  Next
End If
oClassAct.Activate
Worksheets("MaFeuille").Move oClassSource.Sheets(1)
Worksheets("MaFeuille").Copy after:=oClassAct.Sheets(1)
oClassSource.Close False
Il ne vous restera plus qu'un éventuel problème à résoudre
Si votre feuille contient des objets associés à des macros, les macros pointent vers un classeur n'existant plus !!!
Exemple de procédure à ajouter à la fin de la précédente pour remédier à ce problème (cas où les objets en question sont des zones de textes… à adapter pour les autres types d'objets…
Dim oZoneTexte As TextBox
For Each oZoneTexte In ActiveSheet.TextBoxes
  If InStr(1, oZoneTexte.OnAction, "!") > 0 Then
    oZoneTexte.OnAction = Right(oZoneTexte.OnAction, Len(oZoneTexte.OnAction) - InStr(1, oZoneTexte.OnAction, "!"))
  End If
Next

Cette fois-ci, en principe, tout va bien

Retour à la liste

Ajouter une Zone de Texte

Ajouter une Zone de Texte "avec déclenchement macro" (Bouton de commande)
La procédure suivante va exécuter l'ajout de la zone de texte, à "scotcher" sur la cellule active

Sub tester()
  AjoutZoneTexte ActiveCell
End Sub

Sub AjoutZoneTexte(ByVal CelluleSource As Range)
AjoutZoneTexte Macro
' Macro enregistrée le 04/11/2003 par Joël GARBE
Dim VPos As Double
Dim HPos As Double
Dim LZone As Double
Dim HZone As Double
VPos = CelluleSource.Top + 1
HPos = CelluleSource.Left + 1
LZone = CelluleSource.Width
HZone = CelluleSource.Height
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, HPos, VPos, 0#, 0#).Select
Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue
'définit le texte à afficher dans la zone
Selection.Characters.Text = "Ajouter 5" & Chr(10) & "numéros"
With Selection.Characters(Start:=1, Length:=17).Font
  .Name = "Arial
  .FontStyle = "Normal"
  .Size = 10
  .Strikethrough = False
  .Superscript = False
  .Subscript = False
  .OutlineFont = False
  .Shadow = False
  .Underline = xlUnderlineStyleNone
  .ColorIndex = xlAutomatic
End With
With Selection.ShapeRange
  .Fill.Visible = msoTrue
  .Fill.Solid
  .Fill.ForeColor.SchemeColor = 52
  .Fill.Transparency = 0#
  .Line.Weight = 0.75
  .Line.DashStyle = msoLineSolid
  .Line.Style = msoLineSingle
  .Line.Transparency = 0#
  .Line.Visible = msoTrue
  .Line.ForeColor.SchemeColor = 8
  .Line.BackColor.RGB = RGB(255, 255, 255)
  .LockAspectRatio = msoFalse
  .Height = HZone
  .Width = LZone
End With
With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  .Orientation = xlHorizontal
  .AutoSize = False
  End With
'Définit l'action à accomplir quand on cliquera sur la zone de texte
Selection.OnAction = "TestPositionLigne"
'Pour éviter les problèmes…
ActiveCell.Select
End Sub

Reste à connaître la zone de texte qui a déclenché l'exécution de la macro…

Sub TestPositionLigne()
Dim MonObjet As String
Dim iLigne As Integer
Dim iCol As Integer
Application.ScreenUpdating = False
MonObjet = Application.Caller
iLigne = ActiveSheet.Shapes(MonObjet).TopLeftCell.Row
iCol = ActiveSheet.Shapes(MonObjet).TopLeftCell.Column
'Nous avons les coordonnées de la cellule où se trouve la zone de texte
'à nous de savoir quoi en faire…
Cells(iLigne + 1, iCol).Select
'Par exemple
End Sub

Retour à la liste

Une barre de progression simple

A placer de préférence dans un module spécifique
Option Explicit
'Déclaration des variables

Public iL As Long
Public iK As Long
Public sBarre As String
Sub PrepaBarre(ByVal sTB As String)
  'Prépa Barre de progression
  sBarre = sTB
  For iL = 1 To 80
  sBarre = sBarre & "I"
  Next
  iK = 0
  iL = 0
  Application.StatusBar = sBarre
End Sub

Sub AfficheBarre(ByVal NbLigne As Long)
  'Affiche barre de progression
  iK = iK + 1
  On Error Resume Next
    sBarre = Application.StatusBar
  If iK >= (iL + 1) * (NbLigne / Application.WorksheetFunction.Min(NbLigne, 80)) Then
    iL = iL + 1
     iL = Application.WorksheetFunction.Min(80, iL)
    sBarre = Left(sBarre, iL + Len(sBarre) - 81) & "." & Right(sBarre, -iL + 80)
    Application.StatusBar = sBarre
  End If
  On Error GoTo 0
End Sub

'Par exemple: juste pour voir ;-)
'=> c'est dans cette procédure que l'on veut suivre l'avancement de la tâche…

Sub TestBarre()
Dim Ocell As Range
Range("A1:Z800").Value = "jojo"
'Avant d 'entrer dans une boucle, on positionne l'instruction :
PrepaBarre "Texte à afficher : "
Dim NbCycles As Long
NbCycles = Range("A1").CurrentRegion.Count
'NbCycles représente le nombre de "boucles" à effectuer
For Each Ocell In Range("A1").CurrentRegion
  AfficheBarre NbCycles
  Ocell.ClearContents
  'Etc…
Next
MsgBox "C'est fini !!!"
'il faut penser à rétablir la barre d'état standard
Application.StatusBar = False
End Sub

Retour à la liste

Liste des couleurs ColorIndex

Cette procédure va colorier dans la couleur désignée les cellules de la colonne A de la feuille active du classeur actif. Le numéro de ligne correspond au numéro de la couleur
Sub TestCouleur()' Macro créée le 10/03/2004 par Joël GARBE
  Dim i As Integer
  For i = 1 To 56
    Cells(i, 1).Interior.ColorIndex = i
  Next
End Sub

Retour à la liste

Dénombrer les cellules non vides dont la police est d'une certaine couleur

Cette procédure va renvoyer le nombre de cellules non vides à l'intérieur d'une plage, dont la police correspond à une certaine couleur.
De préférence, mettre cette procédure dans le classeur de macros personnelles : PERSO.XLS
Pour savoir si ce classeur existe déjà dans votre environnement, vous pouvez toujours aller dans le menu fenêtre>Afficher… si vous voyez perso.xls dans la boîte de dialogue, il existe.
Dans le cas contraire, il faut le créer.
Pour le créer, (autant faire simple même si ce n'est pas le plus académique !!!), aller dans le menuOutils > Macro > Nouvelle Macro…
Pour le nom de la macro, saisissez un nom bidon : exemple ZAZA, TOTO, JOJO, RAS (espaces, tirets hauts et autres caractères non alphanumériques interdits, à l'exception du tiret bas.
Pour Enregistrer Dans, choisissez "Classeur de Macros Personnelles" et cliquez sur OK.
En principe, une barre d'outils "Arrêt Enregistrement apparaît, cliquez alors sur l'outil Carré : "arrêter l'enregistrement". Si cette barre n'apparaît pas ou si vous l'avez fermée par erreur, aller dans le menu Outils > Macro > Arrêter l'enregistrement.
Votre PERSO.XLS est créé.
Rendez-vous dans Visual Basic Editor (Menu Outils > Macro > Visual Basic Editor)
Dans l'explorateur de projet (sur la partie gauche de l'écran, vous devriez voir un projet VBAProject (PERSO.XLS).
Ouvrez ce projet et double-cliquez sur Module1
Vous pouvez effacer le code s'y trouvant : Sub TOTO() jusqu'à End Sub, puis recopier le code suivant :

Public Function DenombreCouleur(ByVal KelPlage As Range, ByVal KelCouleur As Integer) As Long
  Dim oCell As Range
  DenombreCouleur = 0
  For Each oCell In KelPlage
    If oCell.Font.ColorIndex = KelCouleur And oCell.Value <> "" Then
      DenombreCouleur = DenombreCouleur + 1
    End If
  Next
End Function

Vous avez le droit d'enregistrer avant de quitter Visual Basic Editor (CTRL + S)
À partir de cet instant, vous pouvez récupérer le nombre de cellules dont la police a été mise d'une certaine couleur…
Sélectionnez la cellule où doit apparaître le résultat, allez dans l'assistant fonction , et dans la catégorie Personnalisées, choisissez DenombreCouleur. OK vous emmène sur la boîte de dialogue dans laquelle il vous reste à renseigner la plage à ressencer, et la couleur, sous la forme d'un nombre entier (3 pour le Rouge). Pour connaître la liste des couleurs, voir la procédure précédente dans cette page.
Validez, le tour est joué.

Retour à la liste

Supprimer toutes les liaisons d'un classeur

Cette procédure permet de supprimer l'ensemble des liaisons existantes dans un classeur Excel.
Si la liaison est due à une formule faisant référence à un classeur externe, la cellule est effacée !!!
Si la liaison est due à une cellule nommée faisant référence à une cellule d'un classeur externe, le nom est supprimé.
Si un nom fait référence à une cellule n'existant plus (#REF!), le nom est supprimé…
Si la liaison est due à une zone de texte dont une macro associée fait référence à un classeur externe, la macro est "redirigée" vers le classeur actif.
Option Explicit
Sub SupprimerLiaison()
' Macro créée le 05/06/2004 par Joël GARBE
'Modification le 23/06/2008 pour tenir compte des macros affectées aux contrôles de formulaires' Objectif :
'Supprimer toutes les liaisons externes du classeur
' La liaison fait référence à un classeur externe visible dans le
' Menu Edition / Laisons
' Déclaration des variables
  Dim aLinks As Variant
  Dim oFeuille As Worksheet
  Dim iL As Integer
  Dim oCellForm As Range
  Dim KelNom As name
  Dim ChaineATrouver As String
  Dim NumAS As Integer
  Dim iNb As Integer
  ' Commencer par répertorier les liaisons externes
  aLinks = ActiveWorkbook.LinkSources
  If Not IsEmpty(aLinks) Then
    For iL = 1 To UBound(aLinks)
      NumAS = 0
      ChaineATrouver = ""
      'Reconstruire la chaîne à trouver
      For iNb = 1 To Len(aLinks(iL))
        If Mid(aLinks(iL), iNb, 1) = "\" Then
          NumAS = iNb
        End If
      Next
      If NumAS > 0 Then
        ChaineATrouver = Left(aLinks(iL), NumAS) & "[" & Right(aLinks(iL), Len(aLinks(iL)) - NumAS) & "]"
      End If
      If ChaineATrouver = "" Then
        ChaineATrouver = aLinks(iL)
      End If
      For Each oFeuille In Worksheets
        'il peut s'agir d'une formule... que l'on remplacera par la valeur de la cellule!!!!
        ActiveWorkbook.Unprotect APP_PASSWORD
        oFeuille.Select
        Do
          Set oCellForm = Cells.Find(what:=ChaineATrouver, After:=Range("A1"))
          If Not oCellForm Is Nothing Then
            If Left(oCellForm.Formula, 1) = "=" Then
              ActiveSheet.Unprotect APP_PASSWORD
              oCellForm.Value = oCellForm.Value
            End If
          End If
        Loop Until oCellForm Is Nothing
        'ou d'un nom dans la feuille de calcul
        For Each KelNom In ActiveWorkbook.Names
          If InStr(1, KelNom.RefersTo, "\") > 0 Or InStr(1, KelNom.RefersTo, "#REF!") > 0 Then
            KelNom.Delete
          End If
        Next
        'ou d'un objet dans la feuille de calcul dont la macro associée
        'fait référence à une macro située sur un classeur externe
        'Dans l'exemple qui suit, les objets testés sont les zones de texte
        Dim oZoneTexte As TextBox
        For Each oZoneTexte In ActiveSheet.TextBoxes
          If InStr(1, oZoneTexte.OnAction, "!") > 0 Then
            oZoneTexte.OnAction = ""
          End If
        Next
        'Dans l'exemple qui suit, les objets testés sont les autres contrôles de formulaires
        Dim opTexte As Shape
        For Each opTexte In ActiveSheet.Shapes
          If LCase(Left(opTexte.name, 4)) <> "drop" Then
            If InStr(1, opTexte.OnAction, "!") > 0 Then
              opTexte.OnAction = ""
            End If
          End If
        Next
      Next
    Next iL
  End If
End Sub

Retour à la liste

Bogue Excel 2007 plante à la fermeture

J'avais l'habitude de créer des boutons de commande à l'aide de zone de texte.
Cela fonctionne correctement dans Excel 2007, sauf lorsqu'il s'agit d'imposer la fermeture du classeur, et donc d'utiliser un "Cancel = True"  exemple :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 If Not AutoriserQuit Then
 MsgBox "You must clik on ""Close SAFE"" button on welcome page in order to close the application"
 Cancel = True
 AutoriserQuit = False
 Exit Sub
 End If
 Cancel = False
End Sub

Si le bouton "Close SAFE" est conçu à l'aide d'une zone de texte, cela plante à la fermeture...
Il faut donc utiliser un "Bouton de Commande" standard
Ruban Développeur (Rappel : pour afficher le ruban Développeur, allez dans le bouton Office => Options Excel rubrique Standard)
Le bouton de commande se trouve dans l'Outil Insérer > Bouton (Contrôle de formulaire)

Retour à la liste

Plage nommée de dimension variable

Il arrive très souvent qu'on ait besoin d'utiliser une plage pour effectuer un graphique ou un tableau croisé dynamique par exemple.
Pour faire en sorte que le graphique ou le tableau croisé dynamique s'adapte aux variations de dimensions de la plage source, on va être obligé soit d'insérer des cellules au milieu de la dite plage, ou prévoir une zone plus grande lors de la création, ou encore devoir réajuster les données source après ajout de données.

Pour les tableaux croisés dynamiques, d'autres vont prendre en compte les colonnes entières, ce qui aura pour conséquence de ne pas pouvoir effectuer de regroupement dans le tableau croisé dynamique.

Une solution consiste à déclarer un  plage nommée de dimension variable :

Nommer la plage source (saisir le nom dans la zone nom à gauche de la barre de formule, après avoir sélectionné la plage bien entendu, puis valider, ou utiliser le gestionnaire de noms => ruban formules dans Excel 2007, ou Insertion>Nom>Définir dans les versions antérieures)
dans le Gestionnaire de noms (voir ci-dessus), saisir la formule permettant d'identifier la plage :
=DECALER($A$1;0;0;NBVAL($1:$1);NBVAL($A:$A))
Respecter les dollars "$"
Cette fonction DECALLER (saisie ici dans une cellule car impossible de l'avoir dans le gestionnaire de noms) se présente ainsi :

Le premier argument "Réf" désigne la cellule référence permettant d'identifier la plage
Le second argument "Lignes" représente le nombre de lignes qu'il faut ajouter à la cellule référence pour identifier la première cellule de la plage
Le troisième argument "Colonnes" représente le nombre de colonnes qu'il faut ajouter à la cellule référence pour identifier la première cellule de la plage
Le quatrième argument "Hauteur" représente le nombre de lignes que comporte la plage => c'est ici qu'intervient la partie variable (fonction NBVAL)
Le quatrième argument "Largeur" représente le nombre de colonnes que comporte la plage => c'est ici qu'intervient la partie variable (fonction NBVAL)

Cela suppose bien entendu qu'il n'y ait pas de tableaux annexes sous et à droite de la plage...
Depuis les nouvelles versions 2007 et suivantes, il est plus facile d'établir ce genre de plage sur la base de tableaux...

Retour à la liste

Utilisation de SommeProd

Soit le tableau suivant :

• =SOMMEPROD((B2:B9="HASSIN")*C2:C9) = 14 (c'est à dire 3 + 11)
• =SOMMEPROD(((B2:B9="HASSIN")+(B2:B9="MONFILS"))*C2:C9) = 19 (3 + 11 + 5) (Logique OU)
• =SOMMEPROD((GAUCHE(B2:B9;1)="H")*C2:C9) = 29 (3 + 9 + 11 + 6)
• =SOMMEPROD((A2:A9="Jean")*(B2:B9="PEUPLUS")*C2:C9) = 4 (les deux conditions doivent être réunies logique ET)
• =SOMMEPROD((DROITE(A2:A9;1)="n")*C2:C9) = 18 (4 + 9 + 5) (on additionne les quantités des personnes dont le prénom se termine par "n")
• =SOMMEPROD((DROITE(A2:A9;1)="N")*1) = 3 (on compte le nombre de personne dont la dernière lettre du prénom est un "n"
•  =SOMMEPROD((DROITE(A2:A9;1)="N")*(C2:C9>=5)*C2:C9) = 14 (Jean PEUPLUS ne répond pas au critère >=5)
• =SOMMEPROD(1/NB.SI(B2:B9;B2:B9)) = 7 (il y a 7 noms différents dans la colonne B) (nombre d'item dans la plage)
•  {=SOMME(SI(B2:B9<>"";1/NB.SI(B2:B9;B2:B9)))} = 7 (Formule à valider avec CTRL + MAJ + Entrée à utiliser s'il y a des cellules vides)
•  {=NB(1/FREQUENCE(SI(DROITE(A2:A9;1)="n";EQUIV(A2:A9;A2:A9;0));LIGNE(INDIRECT("1:"&LIGNES(A2:A9)))))} 2 prénoms différents terminent par "n" (Formule à valider avec CTRL + MAJ + Entrée)

Recherche sur plusieurs critères...

Dans le tableau suivant, nous souhaitons récupérer le résultat de l'enregistrement correspondant aux 3 critères ; Prénom, Nom et Ville
La formule à inscrire en D2 est la suivante :
=INDEX(E8:E19;SOMMEPROD((A8:A19=A2)*(B8:B19=B2)*(C8:C19=C2)*(LIGNE(A8:A19)-LIGNE(A7)));1)

Retour à la liste

Ajouter les jours fériés MS Project 2007 et 2010

Insérer le code suivant dans un module du Global.mpt puis ajouter un bouton dans la barre d'outils d'accès rapide pour pouvoir utiliser cette macro.

Le code n'a été testé que dans les version MS Project 2007, 2010 et 2013 !!!

Option Explicit
Dim KelCal As Calendar
Dim iRep As Integer
Dim KelAnD As Integer
Dim KelAnF As Integer

Sub AjoutFeries(ByVal AnneeDeb As Integer, ByVal AnneeFin As Integer)
Dim NumAn As Integer
If AnneeFin < AnneeDeb Then
MsgBox "l'année de fin ne peut pas être inférieure à l'année de début", vbOKOnly + vbExclamation
Exit Sub
End If

For Each KelCal In ActiveProject.BaseCalendars
iRep = MsgBox("Voulez-vous ajouter les jours fériés au calendrier : " & KelCal.Name & " ?" & Chr(10) & Chr(10) & _
"Attention, en cas de conflit, les jours fériés ne seront pas ajoutés", vbYesNo + vbQuestion, "Ajout Fériés")
If iRep = vbYes Then
For NumAn = AnneeDeb To AnneeFin
On Error Resume Next
'Lundi de Pâques
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=Calcul_Date_Paques(NumAn) + 1, Finish:=Calcul_Date_Paques(NumAn) + 1, Name:="Lundi de Pâques"
'Jeudi Ascension
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=Calcul_Date_Paques(NumAn) + 39, Finish:=Calcul_Date_Paques(NumAn) + 39, Name:="Jeudi Ascension"
'Lundi Pentecôte
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=Calcul_Date_Paques(NumAn) + 50, Finish:=Calcul_Date_Paques(NumAn) + 50, Name:="Lundi Pentecôte"
'Nouvel An
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 1, 1), Finish:=VBA.DateSerial(NumAn, 1, 1), Name:="Nouvel An"
'Fête du travail
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 5, 1), Finish:=VBA.DateSerial(NumAn, 5, 1), Name:="Fête du travail"
'Armistice 1945
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 5, 8), Finish:=VBA.DateSerial(NumAn, 5, 8), Name:="Armistice 1945"
'Fête Nationale
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 7, 14), Finish:=VBA.DateSerial(NumAn, 7, 14), Name:="Fête Nationale"
'Assomption
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 8, 15), Finish:=VBA.DateSerial(NumAn, 8, 15), Name:="Assomption"
'Toussaint
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 11, 1), Finish:=VBA.DateSerial(NumAn, 11, 1), Name:="Toussaint"
'Armistice 1918
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 11, 11), Finish:=VBA.DateSerial(NumAn, 11, 11), Name:="Armistice 1918"
'Noël
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=VBA.DateSerial(NumAn, 12, 25), Finish:=VBA.DateSerial(NumAn, 12, 25), Name:="Noël"
On Error GoTo 0
Err.Clear
On Error GoTo 0
Next

End If
Next

End Sub

Sub AjoutJourFerie()
Err.Clear
On Error Resume Next
KelAnD = CInt(InputBox("Saisissez l'année de début pour les jours fériés...", "Année de début"))
If Err.Number <> 0 Then
MsgBox "L'année saisie n'est pas conforme..." & Chr(10) & Chr(10) & "L'opération est annulée", vbOKOnly + vbExclamation, "Erreur Année"
Exit Sub
End If
Err.Clear
On Error Resume Next
KelAnF = CInt(InputBox("Saisissez l'année de Fin pour les jours fériés...", "Année de Fin"))
If Err.Number <> 0 Then
MsgBox "L'année saisie n'est pas conforme..." & Chr(10) & Chr(10) & "L'opération est annulée", vbOKOnly + vbExclamation, "Erreur Année"
Exit Sub
End If

AjoutFeries KelAnD, KelAnF
End Sub

Function Calcul_Date_Paques(Annee_en_cours As Integer) As Date

Dim a, b, C, P, E, F, g, h, i, y, K, r, N, M, D
y = Annee_en_cours
a = fMod(y, 19)
b = Int(y / 100)
C = fMod(y, 100)
P = Int(b / 4)
E = fMod(b, 4)
F = Int((b + 8) / 25)
g = Int((b - F + 1) / 3)
h = fMod(19 * a + b - P - g + 15, 30)
i = Int(C / 4)
K = fMod(C, 4)
r = fMod(32 + 2 * E + 2 * i - h - K, 7)
N = Int((a + 11 * h + 22 * r) / 451)
M = Int((h + r - 7 * N + 114) / 31)
D = fMod(h + r - 7 * N + 114, 31) + 1

Calcul_Date_Paques = DateSerial(Year:=y, Month:=M, Day:=D)

End Function
Function fMod(a, b)

fMod = (a - b * Int(a / b))

End Function

Sub AjoutRTTEquipes()
Err.Clear
On Error Resume Next
If MsgBox("Cette fonctionnalité permet d'ajouter un RTT 2 vendredi sur 3 aux calendriers spécifiés", vbYesNo + vbQuestion, "Ajout RTT") = vbNo Then
MsgBox "Opération Annulée"
Exit Sub
End If
KelAnD = CInt(InputBox("Saisissez l'année de début pour les RTT du Vendredi...", "Année de début"))
If Err.Number <> 0 Then
MsgBox "L'année saisie n'est pas conforme..." & Chr(10) & Chr(10) & "L'opération est annulée", vbOKOnly + vbExclamation, "Erreur Année"
Exit Sub
End If
Err.Clear
On Error Resume Next
KelAnF = CInt(InputBox("Saisissez l'année de Fin pour les RTT du Vendredi...", "Année de Fin"))
If Err.Number <> 0 Then
MsgBox "L'année saisie n'est pas conforme..." & Chr(10) & Chr(10) & "L'opération est annulée", vbOKOnly + vbExclamation, "Erreur Année"
Exit Sub
End If

AjoutRTT KelAnD, KelAnF
End Sub

Sub AjoutRTT(ByVal AnneeDeb As Integer, ByVal AnneeFin As Integer)
Dim NumAn As Integer
If AnneeFin < AnneeDeb Then
MsgBox "l'année de fin ne peut pas être inférieure à l'année de début", vbOKOnly + vbExclamation
Exit Sub
End If

Dim KelDep As Date
Err.Clear
On Error Resume Next
KelDep = VBA.CDate(InputBox("Indiquez la date du premier vendredi souhaité pour l'incorporation des cycles RTT" & Chr(10) & _
"à partir de ce vendredi indiqué, le suivant sera aussi en RTT et le suivant travaillé", "Date de Début"))
If Err.Number <> 0 Then
MsgBox "La date n'a pas été reconnue, l'opération est annulée"
Exit Sub
End If
Err.Clear
On Error GoTo 0
Dim iR As Long
For Each KelCal In ActiveProject.BaseCalendars
iRep = MsgBox("Voulez-vous ajouter les RTT au calendrier : " & KelCal.Name & " ?" & Chr(10) & Chr(10) & _
"Attention, en cas de conflit, les RTT ne seront pas ajoutés", vbYesNo + vbQuestion, "Ajout Fériés")
If iRep = vbYes Then
For iR = 0 To (2 + AnneeFin - AnneeDeb) * 52 Step 3
On Error Resume Next
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=KelDep + iR * 7, Finish:=KelDep + iR * 7, Name:="RTT Vendredi"
ActiveProject.BaseCalendars(KelCal.Name).Exceptions.Add Type:=1, Start:=KelDep + (iR + 1) * 7, Finish:=KelDep + (iR + 1) * 7, Name:="RTT Vendredi"
On Error GoTo 0
Err.Clear
On Error GoTo 0

If VBA.Year(KelDep + (iR + 4) * 7) > AnneeFin Then
Exit For
End If
Next

End If
Next

End Sub