Formation Bureautique - Développement VBA
Si vous souhaitez contribuer à ce site : Faire un don Commentaire ?, écrivez-moi joel.garbe@sfr.fr
Rechercher dans le site : 

 Accueil   |  Débutant & divers  |  Formules  |  Graphiques  |  Base de Données  |  Macro et VBA  |  VBA et autres astuces  |  Les meilleurs sites  |

Quelques procédures VBA

Pour m'écrire Cliquer ici - Need some Help ? Click here

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

 

Barre de Progression

Case à cocher - Check boxes

modifiée 29/06/2004

Dénombrer Cellule Couleur Police

30/06/2004

Liste des couleurs - ColorIndex List

Références Manquantes - Missing references

(26/07/2004)
modifiée 15/01/2017

Supprimer Liaisons

(05/06/04 modifiée 29/06/2004 – 23/06/2008)

Zone de Texte -  Text Boxe

Bogue Excel 2007

(16/04/2009)

Plage dimension variable - Variable size area
(11/02/2010)
SommeProd - SumProd
(01/10/2010)
Mailing Word / Valeurs numériques Excel
(09/02/2011)
Ajouter les jours fériés - Add Bank Holyday
MS Project
(17/07/2012)

Références Manquantes

Préambule :
Cette notion de références manquantes existe lorsque l'on a programmé avec l'idée d'avir 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étodes/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, nour 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'ouvir 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..."

S'il 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

        i = 0

        Call SearchForFiles(fp.sFileRoot)

       

      End If

    End If

   

    ThisWorkbook.VBProject.References.AddFromFile List1(0, 0)

    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 (~$....)

            If MatchSpec(WFD.cFileName, fp.sFileNameExt) And Not _

                    VBA.Left$(WFD.cFileName, 2) = "~$" Then

                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

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

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

 

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

 

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

 

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 menu

Outils > 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é.

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.Visible = True

        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 = "" 'Right(oZoneTexte.OnAction, Len(oZoneTexte.OnAction) - InStr(1, 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 = "" 'Right(opTexte.OnAction, Len(opTexte.OnAction) - InStr(1, opTexte.OnAction, "!"))

            End If

          End If

        Next

      Next

    Next iL

  End If

End Sub

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)

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 :

Boite de dialogue fonction "DECALLER"
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...

Utilisation de SommeProd


Soit le tableau suivant :

 

  A B C
1 Prénom   Nom   Quantité
2 Marc   HASSIN   3
3 Thibault MONFILS 5
4 Jean PEUPLUS 4
5 Marie TOIPAS 3
6 Sylvain HEYBOND 9
7 Marc HASSIN 11
8 Eve HYDANT 6
9 Jean VEUPAS 5
  • =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(E9:E20;SOMMEPROD((A8:A19=A2)*(B8:B19=B2)*(C8:C19=C2)*(LIGNE(A8:A19)-LIGNE(A7)));1)

A B Caen D
1 Prénom Nom Ville Résultat
2 juju TITI Rouen Résultat 6
3
4
5
6
7 Prénom Nom Ville Résultat
8 jojo GAGA Rouen Résultat 1
9 jojo TITI Rouen Résultat 2
10 jojo GAGA Caen Résultat 3
11 jojo TITI Caen Résultat 4
12 juju GAGA Rouen Résultat 5
13 juju TITI Rouen Résultat 6
14 juju GAGA Caen Résultat 7
15 juju TITI Caen Résultat 8
16 toto GAGA Rouen Résultat 9
17 toto TITI Rouen Résultat 10
18 toto GAGA Caen Résultat 11
19 toto TITI Caen Résultat 12

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









Tweet