[REF] Wiki Page 8 de MichelXld

[MichelXld]

Les sujets abordés dans cette page Piloter MSN Messenger et Windows Messenger , Les objets dans la feuille , Les liens hypertextes , Les formats , Visual basic editor , Les chaines de caractères , Les modules de classe.​

Généralités Excel - page 1
Ce qui touche aux userforms - page 2
Piloter d'autres applications depuis Excel - page 3
Fonctions, événements, dates et calendriers - page 4
Formules, audits, répertoires et fichiers - page 5
Doublons, tris et filtres, variables, fichiers fermés, Access - page 6
Commentaires, gestion des erreurs, aide en ligne, recherches, tableaux, pages html, PC et système d'exploitation - page 7
Les objets dans le feuille, liens hypertextes, formats, Visual basic editor, chaines de caractères, modules de classe- page 8
Les Tableaux et graphiques Croisés Dynamiques, fichiers XML - page 9
Le Publipostage Word / Excel - page 10
Librairie Windows Image Acquisition Automation Library v2.0 - page 11​

Piloter MSN Messenger et Windows Messenger depuis Excel

• Quelques exemples pour :
  
  Vérifier si une session est ouverte​
  Fermer la session​
  Afficher le nombre de contacts​
  Boucler sur l'ensemble des contacts et afficher des informations sur chacun d'entre eux​
  Ajouter un contact​
  Supprimer un contact​
  Afficher des informations sur un contact spécifique​
  Bloquer ou débloquer un contact​
  Afficher la boite de dialoque pour se connecter​
  Compter le nombre de messages contenus dans la boite de réception​
  Afficher quelques informations sur mon profil​
  Afficher la page de creation d'un mail​
  Afficher la fenetre d'envoi de message instantané​
  Envoyer un message​
  Modifier votre statut de connection​
  Le lien sur le forum XLD​
• Intercepter l'evenement "réception des messages instantanés" (Windows et MSN Messenger)
  
  Insérez cette procedure dans un USF​
  Si vous recevez un message instantané alors que l'USF est affiché , un Msgbox indique le nom de l'émetteur et le contenu du message​
  Option Explicit​
  Public withEvents msn As msgrObject​
  Private Sub userForm_Initialize()​
  Set msn = New msgrObject​
  End Sub​
  Private Sub msn_onTextReceived(byVal pIMSession As Messenger.IMsgrIMSession, _​
  byVal User As Messenger.IMsgrUser, byVal bstrMsgHeader As String, _​
  byVal Usersay As String, pfEnableDefault As Boolean)​
  msgBox "Vous avez reçu un message de : " & User.friendlyName & vbLf _​
  & vbLf & Usersay​
  End Sub​
• Récupérer la version de MSN Messenger
  
  Dim Msn As messengerAPI.Messenger​
  Set Msn = New messengerAPI.Messenger​
  msgBox Hex(Msn.Property(MMESSENGERPROP_VERSION))​
  Set Msn = Nothing​
• Changer l'image de la carte de visite
  
  Sub changerImageCarteVisite()​
  'necessite d'activer la reference "Messenger API Type Library"​
  Dim Msn As MessengerAPI.Messenger​
  Set Msn = New MessengerAPI.Messenger​
  Msn.myProperty(2) = "C:\Documents and Settings\michel\dossier\nomimage.jpg"​
  End Sub​
• Afficher la boite de réception Hotmail associée à votre session MSN
  
  Sub afficherBoiteReceptionHotMail()​
  'cette procédure présume que votre session MSN est deja ouverte​
  Dim Msn As MessengerAPI.Messenger​
  Set Msn = New MessengerAPI.Messenger​
  Msn.openInbox​
  End Sub​
• Afficher quelques boites de dialogue sur vos parametres MSN
  
  Sub afficherBoitesDialoguesParametresMSN()​
  'necessite d'activer la reference "Messenger API Type Library"​
  Dim Msn As MessengerAPI.Messenger​
  Set Msn = New MessengerAPI.Messenger​
  Msn.optionsPages 0, MOPT_ACCOUNTS_PAGE 'fenetre options generales​
  'Msn.optionsPages 0, MOPT_CONNECTION_PAGE 'fenetre parametres de connection​
  'Msn.optionsPages 0, MOPT_GENERAL_PAGE 'fenetre options personnelles​
  'Msn.optionsPages 0, MOPT_PHONE_PAGE 'fenetre options telephone​
  'Msn.optionsPages 0, MOPT_PRIVACY_PAGE 'fenetres options confidentielles​
  End Sub​
• Lister le nom des groupes
  
  Sub listerNomsGroupes()​
  Dim MSN As MessengerAPI.Messenger​
  Dim msGrpes As IMessengerGroups​
  Dim msGrp As IMessengerGroup​
  Set MSN = New MessengerAPI.Messenger​
  Set msGrpes = MSN.myGroups​
  For Each msGrp In msGrpes​
  msgBox msGrp.Name​
  Next​
  End Sub​
• Déplacer un contact (emailContact@hotmail.com) vers un groupe spécifique
  
  Sub deplacerContactExistantVersGroupeSpecifique()​
  Dim MSN As MessengerAPI.Messenger​
  Dim msGrpes As IMessengerGroups​
  Dim msGrp As IMessengerGroup​
  Set MSN = New MessengerAPI.Messenger​
  Set msGrpes = MSN.myGroups​
  For Each msGrp In msGrpes​
  If msGrp.Name = "nomGroupe" Then msGrp.addContact "emailContact@hotmail.com"​
  Next​
  End Sub​
• Modifier le champ "Ce que j'écoute" sur la carte de visite
  
  Ce lien n'existe plus​

Les objets de la boite à outils Controles (OLEobject) , dans la feuille de calcul

• Débuter : comment insérer une Checkbox ( case à cocher ) dans une feuille
  
  Lien supprimé​
• Débuter : comment insérer un commandButton dans une feuille
  
  Lien supprimé​
• Lier une cellule à un Textbox
  
  ( pour que la valeur de la cellule s'affiche automatiquement dans le Textbox , sans macro )​
  Clic droit sur le Textbox , en mode création​
  Propriétés​
  dans le champ Linkedcell, tu saisies le nom de la cellule ( par exemple A1965 )​
  Un exemple par macro : Créer un textBox et lui associer la propriété linkedCell (cellule B2)​
  Sub creationTextBox_etAjoutLinkedCell()​
  Dim Obj As OLEObject​
  Set Obj = activeSheet.OLEObjects.Add(classType:="Forms.textBox.1", Link:=True, _​
  displayAsIcon:=False, Left:=300, Top:=50, Width:=300, Height:=50)​
  Obj.linkedCell = "B2"​
  End Sub​
• Compter le nombre de Checkboxes cochés ou décochés
  
  Sub compterCheckBox()​
  Dim Obj As OLEObject​
  Dim X As Byte​
  Dim Y As Byte​
  For Each Obj In activeSheet.OLEObjects​
  Y = Y + 1​
  If typeOf Obj.Object Is MSForms.checkBox Then​
  If obj.Object.Value = True Then X = X + 1​
  End If​
  Next​
  msgBox "Il y a " & Chr(10) & X & " checkbox cochées " & _​
  Chr(10) & Y - X & " Checkbox non cochées . "​
  End Sub​
• Créer des Checkbox dans une feuille et les positionner sur des cellules précises
  
  Le lien sur le forum XLD​
• Créer dynamiquement un combobox et le personnaliser
  
  Dim myCombo As OLEObject​
  Set myCombo = activeSheet.OLEObjects.Add(classType:="Forms.comboBox.1", _​
  Link:=False, displayAsIcon:=False, Left:=363.75, Top:=258.75, _​
  Width:=264, Height:=17.25) '.Object​
  With myComb😵bject​
  .Font.Name = "Tahoma" ' la police​
  .Font.Size = 12 ' la taille des caracteres​
  .Font.Bold = False 'non gras​
  .Style = 2 ' pour empecher la saisie manuelle​
  End With​
• Désactiver un commandButton
  
  activeSheet.OLEObjects("commandbutton1").Enabled = False​
• Modifier de façon permanente le Caption d'un commandButton
  
  Workbooks("Classeur1").Sheets("Feuil1").OLEObjects("commandbutton1"). _​
  Object.Caption = "XLD"​
• Creer un bouton , dimensionner et preciser sa position dans la feuille
  
  Sub creerBouton()​
  Dim X As Byte​
  Worksheets(1).OLEObjects.Add "Forms.commandButton.1", _​
  Left:=10, Top:=10, Height:=20, Width:=100​
  X = activeSheet.OLEObjects.Count​
  activeSheet.OLEObjects(X).Object.Caption = "XLD"​
  activeSheet.OLEObjects(X).Object.backColor = RGB(255, 255, 0)​
  End Sub​
• Créer dynamiquement un commandButton dans une feuille et y associer une macro
  
  Le fichier zippé​
• Compter le nombre d'objets dans la feuille active
  
  Sub nbObjetsDansFeuille()​
  msgBox "Il y a " & activeSheet.OLEObjects.Count & " objets dans la feuille ."​
  End Sub​
• Supprimer tous les objets activeX de la feuille active
  
  Sub supprimerOLEobjects()​
  activeSheet.OLEObjects.Delete​
  End Sub​
• Supprimer uniquement les checkbox dans la feuille active
  
  Sub suppresionCheckBoxsFeuille()​
  Dim Obj As OLEObject​
  For Each Obj In activeSheet.OLEObjects​
  If typeOf Obj.Object Is MSForms.checkBox Then Obj.Delete​
  Next​
  End Sub​
• Supprimer le bouton nommé "commandButton1" dans la feuille
  
  Sheets("Feuil1").OLEObjects("commandButton1").Delete​
• Saisie uniquement des valeurs numeriques dans un textbox
  
  'avec la virgule non valide(entier)​
  Private Sub textBox1_Change()​
  On Error Resume Next​
  If Not isNumeric(Right(textBox1, 1)) Then​
  msgBox "Le caractere saisi n'est pas valide"​
  textBox1 = Left(textBox1, Len(textBox1) - 1)​
  End If​
  End Sub​
  'avec la virgule valide(décimal)​
  Private Sub textBox1_Change()​
  On Error Resume Next​
  If Not isNumeric(Right(textBox1, 1)) And Right(textBox1, 1) <> "," Then​
  msgBox "Le caractere saisi n'est pas valide"​
  textBox1 = Left(textBox1, Len(textBox1) - 1)​
  End If​
  End Sub​
• Supprimer les doublons d'un combobox placé dans une feuille
  
  Sub supprimerDoublonsComboboxDansFeuille()​
  Dim x As Integer​
  Feuil1.ComboBox1.Clear​
  For x = 1 To Feuil1.Range("A65536").End(xlUp).Row​
  Feuil1.comboBox1 = Feuil1.Range("A" & x)​
  If Feuil1.comboBox1.listIndex = -1 Then _​
  Feuil1.comboBox1.addItem Feuil1.Range("A" & x)​
  Next x​
  End Sub​
• Modifier un objet diapo powerPoint inséré dans une feuille Excel
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Lancer une présentation PPT contenue dans un fichier Excel
  
  Dim appPPT As Object​
  Dim Obj As Shape​
  Set Obj = Worksheets(1).Shapes(1)​
  Obj.OLEFormat.Activate​
  Set appPPT = Obj.OLEFormat.Object.Object.Application​
  appPPT.activePresentation.slideShowSettings.Run​
• Ajouter un Slide dans une presentation PPT contenue dans un fichier excel
  
  Sub ajoutSlide_objetPowerPoint()​
  Dim appPPT As Object​
  Dim Obj As Shape​
  Dim X As Byte​
  Set Obj = Worksheets(1).Shapes(1)​
  Set appPPT = Obj.OLEFormat.Object.Object.Application​
  'ajouter un slide et le positionner en 2eme position​
  appPPT.activePresentation.Slides.Add Index:=2, Layout:=1​
  X = appPPT.activePresentation.Slides.Count + 1​
  'ajouter un slide et le positionner à la fin​
  appPPT.activePresentation.Slides.Add Index:=X, Layout:=1​
  Range("A1").Select​
  End Sub​
• Lancer un objet inséré dans une feuille : doc Word , diapo PPT , son Wave…etc...
  
  Sub ouvrirObjetInsereDansFeuille()​
  Sheets(1).Shapes(1).Select​
  Selection.Verb Verb:=xlOpen​
  End Sub​
• Lancer un objet inséré dans une feuille : doc Word , diapo PPT , son Wave…2eme version
  
  Sub ouvrirObjetInsereDansFeuilleV02()​
  Worksheets("Feuil1").OLEObjects("objet 1").Verb​
  End Sub​
• Inserer un fichier dans la feuille Excel, avec l'icône objet adapté au format de la cellule active
  
  Private Sub commandButton3_Click()​
  Dim OLEobj As OLEObject​
  Dim Gauche As Double, hautTop As Double, Largeur As Double, Hauteur As Double​
  fileToOpen = Application.getOpenFilename("All Files (.), .")​
  If fileToOpen <> False Then​
  Gauche = activeCell.Left​
  hautTop = activeCell.Top​
  Largeur = activeCell.Width​
  Hauteur = activeCell.Height​
  Set OLEobj = activeSheet.OLEObjects.Add(Filename:=fileToOpen, _​
  Link:=False, displayAsIcon:=True, iconIndex:=0, iconLabel:=fileToOpen)​
  'OLEobj.Name = "leFichier"​
  OLEobj.Left = Gauche​
  OLEobj.Top = hautTop​
  OLEobj.Width = Largeur​
  OLEobj.Height = Hauteur​
  End If​
  End Sub​
• Un bouton unique pour masquer ou afficher des colonnes
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Jouer un son Wave inséré dans la feuille , lors de l'ouverture du classeur
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Jouer un fichier SWF dans un controle "shockWave Flash Object" inséré dans la feuille1
  
  Sub afficherSWF()​
  'dans cet exemple le fichier SWF doit etre placé dans le meme répertoire que le classeur​
  Worksheets(1).shockwaveFlash1.loadMovie 0, thisWorkbook.Path & "\monFichier.swf"​
  Worksheets(1).shockwaveFlash1.Play​
  End Sub​
• Affecter un évenement Click sur un objet shockwaveFlash
  
  Private Sub shockwaveFlash1_gotFocus()​
  msgBox "Le forum Xld"​
  End Sub​
  Cette macro doit etre insérée au niveau de la feuille contenant l'objet shockwaveFlash​
  Important ! pour que cela fonctionne ,il faut qu'une cellule soit activée avant le cliquer sur l'objet shockwaveFlash​
  (Probléme non résolu : puisque l'evenement est géré sur le focus , lors du déplacement dans les différentes feuilles classeur , la macro se déclenchera aussi automatiquement à chaque retour sur la feuille contenant l'objet . )​
• Appeler l'evenement d'un commandButton ( placé dans une feuille ) depuis une autre macro
  
  Application.Run ("Feuil1.CommandButton1_Click")​
• Ajouter des données dans un Objet Word inséré dans la Feuille
  
  Dim wordApp As Object​
  Dim wordObj As Shape​
  Application.screenUpdating = False​
  'dans cet exemple l'objet Word et le 1er objet dans la Feuille​
  Set wordObj = Worksheets(1).Shapes(1)​
  Set wordApp = wordObj.OLEFormat.Object.Object.Application​
  'atteindre la 1ere ligne de l'objet Word​
  wordApp.Selection.goTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1​
  'insérer les données​
  wordApp.Selection.typeText Text:="essai d'insertion" & vbLf & Range("A1") & vbLf​
  Range("A1").Select​
  Application.screenUpdating = True​
• Vérifier si le document Word inséré dans le classeur est vide ou pas
  
  Dim wordApp As Object​
  Dim wordObj As Shape​
  Set wordObj = Worksheets(1).Shapes(1)​
  Set wordApp = wordObj.OLEFormat.Object.Object.Application​
  If wordApp.Selection.Document.Words.Count = 1 Then 'renvoie 1 si vide​
  msgBox "Vide"​
  Else​
  msgBox "Non vide"​
  End If​
  Un autre exemple pour tester parmi plusieurs objets Word contenus dans la feuille​
  Sub Test()​
  msgBox Wvide(3)​
  Range("A1").Select​
  End Sub​
  Function Wvide(i As Integer) As String​
  Dim wordApp As Object​
  Dim wordObj As Shape​
  Set wordObj = activeSheet.Shapes(i)​
  wordObj.OLEFormat.Activate​
  Set wordApp = wordObj.OLEFormat.Object.Object.Application​
  If wordApp.Selection.Document.Words.Count = 1 Then​
  Wvide = "Vide"​
  Else​
  Wvide = "Non vide"​
  End If​
  End Function​
• Appliquer au 1er objet de la feuille la meme couleur que la cellule A1
  
  'OLEObjects(1): premier objet de la Feuil1​
  Sheets("Feuil1").OLEObjects(1).Object.backColor = Worksheets("Feuil1").Cells(1, 1).Interior.Color​
• Utiliser des variables pour agir sur des objets type OLEObjects
  
  Dim nomObj As String​
  Dim numIndex As Integer​
  numIndex = 27​
  nomObj = "Textbox"​
  Feuil1.OLEObjects(nomObj & numIndex).Visible = True​

Les objets formulaires

• Supprimer tous les objets formulaires d'un classeur
  
  Sub supprimObjetsFormulaires()​
  Dim i As Byte​
  For i = 1 To Sheets.Count​
  activeWorkbook.Sheets(i).drawingObjects.Delete​
  Next i​
  End Sub​
  Une autre solution​
  For Each Obj In activeSheet.Shapes​
  If Obj.Type = msoFormControl Then Obj.Delete​
  Next Obj​
• Supprimer uniquement les objets Boutons formulaire dans le feuille active
  
  Sub supprimeBoutonsFormulaire()​
  Dim drawObj As Object​
  On Error Resume Next​
  For Each drawObj In activeSheet.drawingObjects​
  'msgBox typeName(drawObj)'juste pour connaitre le type d'objet​
  If typeName(drawObj) = "Button" Then drawObj.Delete​
  Next​
  End Sub​
• Créer dynamiquement des boutons Formulaires et y associer des macros
  
  Le lien sur le forum XLD​
• Cocher un Checkbox Formulaire par macro
  
  Activesheet.Shapes("Check Box 1").OLEFormat.Object.Value = True​
• Vérifier le statut d'une case à cocher Formulaire
  
  If Sheets("Feuil1").Shapes("Check Box 1").controlFormat.Value = xlOn Then​
  msgBox "Coché"​
  Else​
  msgBox "Décoché" 'xlOff​
  End If​
• Créer et supprimer un Combobox formulaire
  
  Le lien sur le forum XLD​
• Récuperer la donnée affichée dans un Combobox formulaire ( aussi appelé "Zone Combinée" ou "Drop Down")
  
  Le lien sur le forum XLD​
• Spécifier la cellule liée d'un Combobox formulaire (Linkedcell)
  
  activeSheet.Shapes("Zone combinée 1").controlFormat.Linkedcell = "$A$1"​
• Supprimer tous les items d'un Combobox formulaire
  
  Feuil1.Shapes("Zone combinée 1").controlFormat.removeAllItems​
• Désactiver un bouton formulaire
  
  activeSheet.Shapes("Bouton 1").OLEFormat.Object.Enabled = False​
• Créer une liste de choix formulaire dynamiquement
  
  With Worksheets("Feuil1")​
  Set Lbx = .Shapes.addFormControl(xlListBox, 100, 100, 300, 150)​
  Lbx.controlFormat.listFillRange = "Feuil2!A1:A10"​
  Lbx.controlFormat.multiSelect = xlExtended 'autorise la multisélection​
  Lbx.Name = "listBox1"​
  End With​
• Extraire les lignes sélectionnées dans une liste de choix paramétrée en multisélection
  
  Dim i As Integer​
  With activeWorkbook.Worksheets("Feuil1")​
  For i = 1 To .listBoxes("listBox1").listCount​
  If .listBoxes("listBox1").Selected(i) Then Debug.Print .listBoxes("listBox1").List(i)​
  Next i​
  End With​

Les liens hypertextes et les liaisons

• Extraire les liens hypertextes d'une colonne
  
  Le lien sur le forum XLD​
• Lister les feuilles du classeur , dans l'onglet "bilan" et ajouter des liens hypertextes
  
  Sub creerLiensFeuilles()​
  Dim I As Byte, J As Byte​
  Dim Valeur As String​
  For I = 1 To Sheets.Count​
  If Not Sheets(I).Name = "Bilan" Then​
  Valeur = "'" & Sheets(I).Name & "'!A1"​
  J = J + 1​
  Worksheets(I).Hyperlinks.Add Anchor:=Sheets("Bilan").Cells(J, 1), Address:="", subAddress:=Valeur​
  End If​
  Next I​
  End Sub​
• Changer un mot dans un lien hypertexte
  
  Le lien sur le forum XLD​
• Supprimer tous les liens hypertextes d'une feuille
  
  Le lien sur le forum XLD​
• Afficher la boite de dialogue pour gérer les liens hypertextes
  
  Sub afficheBteLiens()​
  Application.Dialogs(xlDialogInsertHyperlink).Show​
  End Sub​
• Créer un lien hypertexte dans la cellule A1
  
  Sub creerHyperlien()​
  Worksheets(1).Hyperlinks.Add Range("A1"), "http://www.excel-downloads.com"​
  End Sub​
• Créer un lien hypertexte dans la cellule A1 , pour accéder à la cellule A200 de la Feuil3 d'un classeur Excel
  
  Worksheets(1).Hyperlinks.Add Anchor:=Range("A1"), Address:= _​
  "C:\monClasseur.xls", subAddress:="feuil3!A200"​
• Controler la présence d'un lien hypertexte dans la cellule A1
  
  Sub controlePresenceHyperlien()​
  If Range("A1").Hyperlinks.Count = 0 Then​
  msgBox "il 'y a pas de lien hypertexte dans la cellule A1"​
  Else​
  msgBox "il y a un lien hypertexte dans la cellule A1 , dont l'adresse est : " & vbLf & _​
  Range("A1").Hyperlinks.Item(1).Address​
  'utilisez Range("A1").Hyperlinks.Item(1).subAddress pour afficher un lien vers une autre cellule du classseur​
  End If​
  End Sub​
• Déclencher le lien hypertexte contenu dans la cellule A1
  
  Range("A1").Hyperlinks(1).Follow newWindow:=True​
• Extraire tous les liens attachés aux images palcées dans une feuille
  
  Sub boucleImagesFeuille_recupLiens()​
  Dim Sh As Shape​
  Dim i As Integer​
  For Each Sh In Worksheets("Feuil1").Shapes​
  If Sh.Type = msoPicture Then​
  i = i + 1​
  On Error goTo Suite 'gestion d'erreur si une des images ne contient pas de lien​
  Cells(i, 6) = Sh.Hyperlink.Address​
  Suite:​
  End If​
  Next​
  End Sub​
• Désactiver les liaisons lors de l'ouverture du classeur
  
  Le lien sur le forum XLD​
• Incrémenter un compteur à chaque fois que le lien hypertexte placé dans la cellule A1 est lancé
  
  Private Sub Worksheet_followHyperlink(byVal Target As Hyperlink)​
  If Target.Range.Address = "$A$1" Then Range("A2") = Range("A2") + 1​
  End Sub​
• Recréer des liens hypertexte dans un classeur ,suite à un déplacement de dossiers .Une démo de Didier (myDearFriend)
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Auditer les liens hypertextes d'un classeur . Une démo de Didier (myDearFriend)
  
  Le lien sur le forum XLD ( voir le message du 16/11/2005 23:48 )​
  Lien supprimé​

Les formats

• Afficher quelques informations sur les parametres du poste de travail
  
  Sub formatMonetairePC()​
  msgBox Application.International(25)​
  msgBox Application.International(xlCurrencyCode) 'equivalence​
  End Sub​
  Sub formatSeparateurDatePC()​
  msgBox Application.International(xlDateSeparator)​
  End Sub​
  Sub formatSeparateurColonnePC()​
  msgBox Application.International(xlColumnSeparator)​
  End Sub​
  Sub formatSeparateurColonnePC()​
  msgBox Application.International(xlColumnSeparator)​
  End Sub​
• Connaître la version de langue ( Français , Anglais …) d'Excel
  
  Range("A1") = Application.International(xlCountryCode)​
  Quelques valeurs renvoyées :​
  1: US English​
  33: French​
  49: German​
• Ajouter automatiquement un texte à la suite de la valeur saisie dans une cellule
  
  Par exemple ajouter une unité de mesure :​
  Appliquez le format personnalisé 0.00" Mon unité de mesure"​
• Vérifier le format d'une plage de cellules sélectionnée
  
  Sub testFormatCellulesDansSelection()​
  'Controler si les cellules ont le format spécifié :yyyy-mm-dd Dim Cell As Range​
  For Each Cell In Selection​
  If Not Cell.numberFormat = "yyyy-mm-dd" Then _​
  msgBox "La cellule " & Cell.Address & " n'a pas le format yyyy-mm-dd"​
  Next Cell​
  End Sub​
• Des Mises en Forme Conditionnelles personnalisées et multiples
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Les codes couleurs : équivalence RGB , Long , Hex
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Afficher le code couleur RGB pour la cellule A1
  
  Sub referenceCouleurRGB_cellule()​
  Dim Red As Integer, Green As Integer, Blue As Integer​
  Dim Couleur As Long​
  Couleur = Range("A1").Interior.Color​
  Red = Couleur And 255​
  Green = Couleur \ 256 And 255​
  Blue = Couleur \ 256 ^ 2 And 255​
  msgBox Red & " * " & Green & " * " & Blue​
  End Sub​
• Quelques formats personnalisés
  
  msgBox Format(Date, "dddd dd mmmm yyyy") ' Renvoie "Vendredi 26 mai 1965"​
  msgBox Format(5459.4, "##,##0.00") ' Renvoie "5 459,40".​
  msgBox Format(334.934567, "###0.00") ' Renvoie "334,93".​
  msgBox Format(5, "0.00%") ' Renvoie "500,00%".​
  msgBox Format("BONJOUR", "<") ' Renvoie "bonjour".​
  msgBox Format("Et voilà!", ">") ' Renvoie "ET VOILÀ!".​
• Pour transformer une valeur décimale en fraction (par exemple 5,5 donne 11/2 ) :
  
  Appliquez le format ???#/???# à la cellule​
• Afficher directement une fraction dans une cellule ( une solution donnée par André )
  
  Tu tapes 0, puis un espace, puis ta fraction (par exemple 1/4).​
  La cellule se met automatiquement en format fraction.​
  Si tu tapes 6/4 tu obtiens 1 1/2​
  Pour 4/6 tu obtiens 2/3​
  Si tu tapes 0 2*1/4 tu obtiens 0.5 et non 1/2​
  Si tu tapes d'abord 0 1/4, puis que tu modifies ta cellule en 2*1/4, tu obtiens bien 1/2 (parce par ta première entrée a modifié le format de la cellule).​
  Si tu as 1/4 en A1 et que tu tapes =2*A1 en B1 tu obtiens bien 1/2​
• Empecher la réduction de la fraction
  
  Par exemple , pour afficher 5/50 dans la cellule il faut appliquer le format personnalisée #" "???/50 dans la cellule​
• Ne pas faire apparaitre les Zéro "0" dans une cellule( une solution donnée par Gerard )
  
  Appliquez à la cellule le format [=0]"";Standard​
  Une autre possibilité en personnalisant le format de la cellule​
  Format de cellule​
  Personnalisé​
  Saisissez le format 0,0;-0,0;""​
  Une autre possibilité :​
  Menu Options​
  Onglet Affichage​
  Décoches l'option "Valeurs zéro"​
• Compter le nombre de styles et formats utilisé dans le classeur
  
  msgBox thisWorkbook.Styles.Count​
• Afficher le code ascii d'un caractere ( utilisation de la fonction ASC )
  
  Msgbox Asc("A") ' renvoie 65​
• Lister les polices en utilisant la barres d'outils Format .Une procédure d'Alain Vallon
  
  Les informations sont listées dans un combobox placé dans la Feuil1​
  Sub zz_iniComboListePolices()​
  'Lien supprimé​
  With Sheets("Feuil1")​
  .comboBox1.Clear​
  Set C = Application.commandBars.findControl(ID:=1728)​
  For I = 1 To C.listCount​
  .comboBox1.addItem C.List(I)​
  Next I​
  End With​
  End Sub​
• Afficher le nom du fichier FONT correspondant à la police utilisée dans la cellule A1
  
  Le lien sur le forum XLD​
• Isoler un numéro de telephone contenu dans le texte d'une cellule (une procedure Didier myDearFriend )
  
  Sub isoleNumTel()​
  Dim Chaine As String​
  Chaine = Selection.Value​
  If Chaine Like "## ## ## ## ##" Then​
  Do​
  Chaine = Mid(Chaine, 2)​
  Loop Until Chaine Like "## ## ## ## ##*"​
  Chaine = Left(Chaine, 14)​
  msgBox Chaine​
  End If​
  End Sub​
• Transformer une Date qui est au format texte ( 07.05.2005 ) en format Date reconnu (07/05/2005 )
  
  Sub formatDate()​
  Dim Annee As Integer, Mois As Integer, Jour As Integer​
  Annee = Right(Range("A1"), 4)​
  Mois = Mid(Range("A1"), 4, 2)​
  Jour = Left(Range("A1"), 2)​
  Range("A1") = dateSerial(Annee, Mois, Jour)​
  End Sub​
• Masquer la donnée saisie dans une cellule
  
  Appliquez le format personnalisé ;;; ( 3 points virgules )​
• Extraire et fusionner des listes de correction automatique
  
  La question :​
  Je viens de changer de machine et je voudrais récupérer toutes mes abréviations saisies en correction automatique, où et quel fichier récupérer dans mon ancien pc ?​
  Y a-t-il moyen de fusionner ce fichier avec le même de ma machine du travail pour avoir toutes les abréviations partout dans un seul et même fichier ?​
  La premiere macro( a utiliser dans un classeur de ton ancienne machine ) permet de récupérer toutes les données de l'option correction automatique​
  Sub listerOptionsAutoCorrection()​
  Dim Tableau()​
  Dim X As Integer​
  Tableau = Application.autoCorrect.replacementList​
  For X = 1 To UBound(Tableau)​
  Cells(X, 1) = Tableau(X, 1)​
  Cells(X, 2) = Tableau(X, 2)​
  Next​
  End Sub​
  Ensuite tu transferts le classeur contenant ces données sur ta nouvelle machine et tu lances la 2eme macro .​
  La procedure va controler si les données du classeur existent deja dans la liste des options automatiques de la nouvelle machine .​
  Si les données n'existent pas , elles vont etre ajoutées à la liste de la nouvelle machine .​
  Bien sur ce n'est qu'un exemple , et tu devras sans doute l'adapter à ton projet (remise en forme du tableau avant le transfert …etc…)​
  Sub fusionOptionsAutoCorrection()​
  'Lien supprimé Dim Tableau()​
  Dim X As Integer​
  Dim Cell As Range​
  Dim Cible As Boolean​
  Tableau = Application.autoCorrect.replacementList​
  For Each Cell In Range("A1:A" & Range("A65536").End(xlUp).Row)​
  Cible = False​
  For X = 1 To UBound(Tableau)​
  If Tableau(X, 1) = Cell Then​
  Cible = True​
  Exit For​
  End If​
  Next X​
  If Cible = False Then Application.autoCorrect.addReplacement Cell, Cell.Offset(0, 1)​
  Next Cell​
  End Sub​
• Comment Excel se comporte et interprète les valeurs numériques préfixées d'une apostrophe
  
  Le lien sur le forum XLD​
• Quelques informations sur les symboles utilisés dans les formats de cellule :
  
  Le symbole # indique un chiffre.​
  Quelques exemples :​
  Forcer l'arrondi à deux chiffres après la virgule: 123,456 au format ###,## affichera 123,46​
  Insérer une séparation de milliers : 1234 au format ### ### affichera 1 234​
  Le symbole 0 indique aussi un chiffre (Il est presque indentique à #) . Ce symbole permet d'afficher les 0 après la virgule :​
  123,45 au format ###,000 affiche 123,450​
  123,450 au format ###,### affiche 123,45​
  Le symbole * Permet de répéter un caractère pour remplir une cellule.​
  Par exemple, appliquez le format #*- dans une cellule , puis saisissez une valeur numérique dans cette cellule. Des tirets s'ajoutent à la suite du chiffre ,jusqu'au bord droit de la cellule .​
  Un autre exemple pour des données Alpha: @*+​
  Le symbole ? permet d'aligner les données contenues dans une plage de cellules .​
  Par exemple , Appliquez ce format ? ???,?????? à une plage de cellules contenant des valeurs décimales de longueur différente (1,02 456,8955 34,9 …etc...)​

Visual Basic Editor

• Remarque :
  
  Lors de l'utilisation des procédures qui agissent sur les modules , des message d'erreur liés à des "type d'incomptatibilité" peuvent survenir​
  Dans ce cas il faut activer la référence "Microsoft Visual Basic for Applications Extensibility 5.3 "​
  Dans Visual Basic Editor (Alt+F11 ) :​
  Menu Outils​
  References​
  Cochez la ligne "Microsoft Visual Basic for Applications Extensibility 5.3"​
  Cliquez sur "OK" pour valider​
• Quelques informations sur les propriétés VBComponents et codeModule
  
  VBComponents renvoie la collection de composants contenue dans un projet​
  1 pour thisWorkbook​
  2 à x en fonction du nombre de feuilles​
  ensuite x+1 pour chaque module​
  par exemple​
  Sub boucleVBComponents()​
  Dim i As Integer​
  For i = 1 To activeWorkbook.VBProject.VBComponents.Count​
  msgBox activeWorkbook.VBProject.VBComponents(i).Name​
  Next​
  End Sub​
  codeModule permet de modifier , ajouter , supprimer , ou renvoyer des informations sur le texte du code , pour chaque composant​
  par exemple pour compter le nombre de lignes de chaque composant​
  Dim Mdl As codeModule​
  Dim i As Integer​
  For i = 1 To activeWorkbook.VBProject.VBComponents.Count​
  Set Mdl = activeWorkbook.VBProject.VBComponents(i).codeModule​
  msgBox Mdl.countOfLines​
  Next​
• Creation d'un multipage dans un userform
  
  Le lien sur le forum XLD​
  Le fichier zippé​
• Modification des propriétés d'un commandButton dans un userform
  
  thisWorkbook.VBProject.VBComponents("userForm1"). _​
  Designer.Controls("commandButton1").backColor = &H80C0FF​
• Créer un userForm et une Listbox par macro
  
  Une macro evenementielle "Click" va aussi etre rattachée à la Listbox​
  Option Explicit​
  Dim Usf As Object​
  Sub lancementProcedure()​
  Dim X As Object​
  Dim i As Integer​
  Dim strList As String​
  strList = "listBox1"​
  Set X = creationUserForm_Et_listBox_Dynamique(strList)​
  For i = 1 To 10​
  X.Controls(strList).addItem "Donnee " & i​
  Next i​
  X.Show​
  thisWorkbook.VBProject.VBComponents.Remove Usf​
  Set Usf = Nothing​
  End Sub​
  Function creationUserForm_Et_listBox_Dynamique(nomListe As String) As Object​
  Dim objListBox As Object​
  Dim j As Integer​
  Set Usf = thisWorkbook.VBProject.VBComponents.Add(3)​
  With Usf​
  .Properties("Caption") = "Mon userForm"​
  .Properties("Width") = 300​
  .Properties("Height") = 200​
  End With​
  Set objListBox = Usf.Designer.Controls.Add("Forms.listBox.1")​
  With objListBox​
  .Left = 20: .Top = 10: .Width = 90: .Height = 140​
  .Name = nomListe​
  .Object.columnCount = 1​
  .Object.columnWidths = 70​
  End With​
  With Usf.codeModule​
  j = .countOfLines​
  .insertlines j + 1, "Sub " & nomListe & "_Click()"​
  .insertlines j + 2, "If Not " & nomListe & ".listIndex = -1 Then msgBox " & nomListe​
  .insertlines j + 3, "End Sub"​
  End With​
  VBA.userForms.Add (Usf.Name)​
  Set creationUserForm_Et_listBox_Dynamique = userForms(userForms.Count - 1)​
  End Function​
• Compter le nombre de Userforms dans un classeur
  
  Private Sub listBox1_Click()​
  Dim Fichier As String​
  Dim VBComp As VBComponent​
  Dim Valeur As Byte​
  Fichier = listBox1.Value​
  For Each VBComp In Workbooks(Fichier).VBProject.VBComponents​
  If VBComp.Type = 3 Then Valeur = Valeur + 1​
  Next VBComp​
  msgBox " Il y a " & Valeur & " userform dans le fichier " & Fichier​
  End Sub​
• Afficher toutes les procédures du classeur
  
  Sub listeMacros()​
  'necessite d'activer la reference Microsoft Visual basic For Application Extensibility 5.3​
  Dim i As Integer, Ajout As Integer​
  Dim Msg As String​
  Dim VBCmp As VBComponent​
  Dim x As Integer​
  Ajout = 1​
  For Each VBCmp In thisWorkbook.VBProject.VBComponents​
  Msg = VBCmp.Name​
  With Cells(Ajout, 1)​
  .Interior.colorIndex = 6​
  .Value = Msg​
  End With​
  x = thisWorkbook.VBProject.VBComponents(Msg).codemodule.countOfLines​
  For i = 1 To x​
  Cells(Ajout + i, 1) = thisWorkbook.VBProject.VBComponents(Msg).codemodule.Lines(i, 1)​
  Next​
  Ajout = Ajout + x + 2​
  Next VBCmp​
  End Sub​
• Lister le nom des macros du classeur actif
  
  Sub listeNomsMacros()​
  Dim Mdl As Object​
  Dim i As Integer, Y As Integer​
  Dim X As Byte​
  Dim Cible As String​
  For i = 1 To activeWorkbook.VBProject.VBComponents.Count​
  Set Mdl = activeWorkbook.VBProject.VBComponents(i).codemodule​
  With Mdl​
  For Y = 1 To .countOfLines​
  Cible = activeWorkbook.VBProject.VBComponents(Mdl).codemodule.Lines(Y, 1)​
  Cible = Application.Substitute(Cible, " ", "")​
  If Len(Application.Substitute(Cible, "Sub", "")) < Len(Cible) Then​
  If Left(Cible, 3) = "Sub" Or Left(Cible, 7) = "Private" Then​
  X = X + 1​
  Cells(X, 1) = activeWorkbook.VBProject.VBComponents(Mdl).codemodule.Lines(Y, 1)​
  End If​
  End If​
  Next​
  End With​
  Next​
  End Sub​
• Afficher la version VBE utilisée
  
  Sub afficherLaVersionVBE()​
  msgBox Application.VBE.Version​
  End Sub​
• Afficher le nom de la procedure en cours
  
  Le lien sur le forum XLD​
• Supprimer une procedure Workbook_Open par macro
  
  A chaque ouverture du classeur contenant la macro , une copie du document est créée , expurgée de la procédure Workbook_Open​
  Private Sub Workbook_Open()​
  Dim Debut As Integer, Lignes As Integer​
  'enregistrement du nouveau classeur​
  Thisworkbook.Saveas Filename:="C:\excel\enregistrement " & Format(Time, "hh mm ss") & ".xls"​
  'suppression de la procedure Workbook_Open​
  With Thisworkbook.VBProject.VBComponents("Thisworkbook").codemodule​
  Debut = .Procstartline("Workbook_Open", 0)​
  Lignes = .Proccountlines("Workbook_Open", 0)​
  .Deletelines Debut, Lignes​
  End With​
  'sauvegarde modification​
  Thisworkbook.Save​
  End Sub​
• Supprimer la macro nommée "maMacro" dans le "Module3"
  
  Sub supprimerUneMacroPrecise()​
  Dim Debut As Integer, Lignes As Integer​
  With thisWorkbook.VBProject.VBComponents("Module3").codeModule​
  Debut = .procStartLine("maMacro", 0)​
  Lignes = .procCountLines("maMacro", 0)​
  .deleteLines Debut, Lignes​
  End With​
  End Sub​
• Supprimer un module
  
  Sub supprimerUnModule()​
  With thisWorkbook.VBProject.VBComponents​
  .Remove .Item("Module2")​
  End With​
  End Sub​
• Supprimer un Userform par macro
  
  Sub suppressionUSF()​
  'necessite d'activer la reference Microsoft Visual Basic for Applications Extensibility 5.3​
  Dim VBComp As VBComponent​
  Set VBComp = thisWorkbook.VBProject.VBComponents("userForm1")​
  thisWorkbook.VBProject.VBComponents.Remove VBComp​
  End Sub​
• Supprimer la totalité des procédures du classeur
  
  Sub supprimeToutVBA()​
  'copie le classeur en supprimant la totalité des procedures​
  Dim vbComp As VBComponent​
  thisWorkbook.saveAs "C:\test.xls"​
  For Each vbComp In activeWorkbook.VBProject.VBComponents​
  Select Case vbComp.Type​
  Case 1 To 3​
  activeWorkbook.VBProject.VBComponents.Remove vbComp​
  Case Else​
  With vbComp.codeModule​
  .deleteLines 1, .countOfLines​
  End With​
  End Select​
  Next vbComp​
  activeWorkbook.Save​
  End Sub​
• Supprimer la 3eme ligne de la procédure "maMacro" , placée dans le Module1
  
  Sub supprimerLigneMacro()​
  Dim Debut As Integer​
  With thisWorkbook.VBProject.VBComponents("Module1").codemodule​
  Debut = .procStartLine("maMacro", 0)​
  .deleteLines Debut + 3, 1​
  End With​
  End Sub​
• Créer dynamiquement un commandButton dans une feuille et y associer une macro
  
  Le fichier zippé​
• Créer une macro évènementielle au niveau de la feuille (Feuil1) , par macro
  
  Sub creationMacro()​
  Dim X As Integer​
  'creation procedure dans la Feuil1​
  'activer la reference Microsoft Visual Basic for Applications Extensibility 5.3​
  'si la procedure ne fonctionne pas​
  With activeWorkbook.VBProject.VBComponents("Feuil1").codeModule​
  X = .countOfLines​
  .insertLines X + 1, "Private Sub workSheet_Calculate()"​
  .insertLines X + 2, "'bla bla bla"​
  .insertLines X + 3, "msgBox ""Calcul effectué . "",,""Message"" "​
  .insertLines X + 4, "End Sub"​
  End With​
  End Sub​
• Créer un nouveau module dans le classeur et y insérer une macro
  
  Le lien sur le forum XLD​
• Ajouter par macro une référence manquante
  
  Le lien sur le forum XLD​
  Un autre exemple​
  x = "C:\Program Files\Fichiers communs\Microsoft Shared\DAO\Dao360.dll"​
  activeWorkbook.VBProject.References.addFromFile x​
• Remplacer un module dans tous les classeurs d'un répertoire
  
  Le lien sur le forum XLD​
• Repérer dans un répertoire tous les classeurs qui contiennent des macros
  
  une procédure de Didier myDearFriend​
  Le lien sur le forum XLD​
• Ajouter dynamiquement un Progressbar dans un userform
  
  Le lien sur le forum XLD​
• Supprimer les modules vides dans le classeur actif
  
  Sub supprimerTousModulesVides()​
  Dim vbComp As Object​
  Dim i As Long, j As Long​
  For Each vbComp In activeWorkbook.VBProject.VBComponents​
  If vbComp.Type = 1 Then​
  i = vbComp.codeModule.countOfDeclarationLines + 1​
  j = vbComp.codeModule.countOfLines​
  If j < i Then activeWorkbook.VBProject.VBComponents.Remove vbComp​
  End If​
  Next​
  End Sub​
• Afficher la fenetre Visual Basic Editor
  
  Application.VBE.mainWindow.Visible = True​
• Remplacer une macro dans tous modèles Word .DOT d'un répertoire ( procédure vba Word )
  
  Sub remplacement_Macro_wordDot()​
  Dim Debut As Integer, Lignes As Integer, X As Integer​
  Dim Fichier As String, Direction As String​
  Dim Doc As Document​
  Application.screenUpdating = False​
  'boucle sur tous les fichiers .dot du repertoire​
  Direction = "C:\Documents and Settings\michel\dossier\general\excel"​
  Fichier = Dir(Direction & "\*.dot")​
  Do While Fichier <> ""​
  Set Doc = Documents.Open(Direction & "\" & Fichier)​
  'suppression macro nommée "essai" dans module1​
  With Doc.VBProject.VBComponents("Module1").codeModule​
  Debut = .procStartLine("essai", 0)​
  Lignes = .procCountLines("essai", 0)​
  .deleteLines Debut, Lignes​
  End With​
  'ajout macro nommée "maNouvelleMacro" dans Module1​
  With Doc.VBProject.VBComponents("Module1").codeModule​
  X = .countOfLines​
  .insertLines X + 1, "Sub maNouvelleMacro()"​
  .insertLines X + 2, "msgBox ""Coucou"",VBinformation "​
  .insertLines X + 3, "End Sub"​
  End With​
  doEvents​
  Doc.Close True​
  Set Doc = Nothing​
  Fichier = Dir​
  Loop​
  Application.screenUpdating = True​
  End Sub​
• Vérifier l'existence d'un module et d'un userForm dans un classeur
  
  Sub Test()​
  controleVBE "userForm1", "Classeur1.xls"​
  controleVBE "module1", "Classeur1.xls"​
  End Sub​
  Sub controleVBE(Cible As String, Classeur As String)​
  'necessite d'activer la reference​
  'Microsoft Visual Basic for Applications Extensibility 5.3​
  Dim VBComp As VBComponent​
  On Error Resume Next​
  Set VBComp = Workbooks(Classeur).VBProject.VBComponents(Cible)​
  If VBComp Is Nothing Then​
  msgBox "n'existe pas"​
  Else​
  msgBox "Existe"​
  End If​
  End Sub​
• Vérifier si une macro précise existe dans un classeur
  
  Sub Test2()​
  controlePresenceMacro "nomMacro", "Classeur1.xls"​
  End Sub​
  Sub controlePresenceMacro(Cible As String, Classeur As String)​
  'verifies si la macro "nomMacro" existe dans le classeur nommé "classeur1.xls"​
  'necessite d'activer la reference Visual basic For Application Extensibility 5.3​
  Dim Msg As String​
  Dim VBCmp As VBComponent​
  Dim Debut As Integer​
  Debut = 0​
  On Error Resume Next​
  For Each VBCmp In Workbooks(Classeur).VBProject.VBComponents​
  Msg = VBCmp.Name​
  With Workbooks(Classeur).VBProject.VBComponents(Msg).codeModule​
  Debut = .procStartLine(Cible, 0)​
  End With​
  If Debut > 0 Then Exit For​
  Next VBCmp​
  If Debut = 0 Then​
  msgBox "n'existe pas"​
  Else​
  msgBox "Existe"​
  End If​
  End Sub​
• Controler l'existence d'un mot dans le projet VBE d'un classeur
  
  Sub rechercheVBE()​
  'activer la reference Visual basic For Application Extensibility 5.3​
  Dim i As Integer, x As Integer​
  Dim Fichier As String, Recherche As String, Msg As String​
  Dim Ligne As String​
  Dim VBCmp As VBComponent​
  Fichier = "monClasseur.xls"​
  Recherche = "leMot"​
  For Each VBCmp In Workbooks(Fichier).VBProject.VBComponents​
  Msg = VBCmp.Name​
  x = Workbooks(Fichier).VBProject.VBComponents(Msg).codemodule.countOfLines​
  For i = 1 To x​
  Ligne = Workbooks(Fichier).VBProject.VBComponents(Msg).codemodule.Lines(i, 1)​
  If inStr(1, Ligne, Recherche, vbTextCompare) Then​
  msgBox "True"​
  Exit Sub​
  End If​
  Next​
  Next VBCmp​
  msgBox "False"​
  End Sub​
• Lister les macros complémentaires du poste
  
  Sub listerMacroComplementaires()​
  Dim X As addIn​
  Dim Resultat As String​
  For Each X In Application.addIns​
  Resultat = Resultat & X.Name & vbLf​
  Next X​
  msgBox Resultat​
  End Sub​
• Vérifier si une macro complémentaire est installée
  
  Option Compare Text​
  Sub controler_Si_macroComplementaire_Installee()​
  Dim X As addIn​
  Dim laMacro As String​
  laMacro = "solver.xla"​
  For Each X In Application.addIns​
  If laMacro = X.Name Then​
  If X.Installed = True Then​
  msgBox "la macro complémentaire " & laMacro & " est installée ."​
  Else​
  msgBox "la macro complémentaire " & laMacro & " n'est pas installée ."​
  End If​
  Exit Sub​
  End If​
  Next X​
  msgBox "la macro complémentaire " & laMacro & " n'a pas été trouvée ."​
  End Sub​
• Activer l'Utilitaire d'analyse - VBA (atpvbaen.xls)
  
  ( à ne pas confondre avec l'Utilitaire d'Analyse )​
  dans la feuille de Calcul ,​
  Menu Outils​
  Macros complémentaires​
  Coches la ligne "Utilitaire d'analyse - VBA"​
  Cliques sur OK pour valider​
  ensuite , dans l'éditeur de macro ( Alt+F11)​
  Menu Outils​
  References​
  coches la ligne "atpvbaen.xls"​
  Cliques sur OK pour valider​
• Automatiser l'installation d'un Addin .xla
  
  Sub installationAddIn()​
  Dim oAddin As addIn​
  Set oAddin = Application.addIns.Add("C:\leFichier.xla", True)​
  oAddin.Installed = True​
  End Sub​
• Ajouter un calendrier dynamiquement dans un userform
  
  Dim Usf As Object​
  Dim Obj As MSACal.Calendar​
  Set Usf = thisWorkbook.VBProject.VBComponents("Userform1")​
  Set Obj = Usf.Designer.Controls.Add("MSCAL.Calendar.7")​
  With Obj​
  .Left = 20: .Top = 20: .Width = 200: .Height = 150​
  End With​
  VBA.userForms.Add (Usf.Name)​
  userForms(0).Show​
• Utiliser des raccourcis claviers pour se déplacer dans l'éditeur de macros
  
  Des astuces proposées par Creepy et Ti​
  Le lien sur le forum XLD​
• Exporter et réimporter des modules et userforms dans des classeurs
  
  La procedure exporte 3 modules et 1 userform du classeur contenant la macro . Ensuite la macro boucle sur tous les classeurs d'un repertoire cible pour réimporter ces modules et userform​
  Sub Export_Import_Module_Et_Userform()​
  Dim Fichier As String, Repertoire As String​
  Dim Wb As Workbook​
  Dim i As Byte​
  Application.screenUpdating = False​
  '-----------------------------------​
  'export du userForm1 et de 3 Modules nommés Module1 , Module2 et Module3​
  'qui sont dans le classeur contenant cette macro​
  thisWorkbook.VBProject.VBComponents("userForm1").Export "C:\copieUSF.frm"​
  For i = 1 To 3​
  thisWorkbook.VBProject.VBComponents("Module" & i).Export "C:\copieModule" & i & ".bas"​
  Next i​
  '-----------------------------------​
  'adaptes le repertoire des classeurs à modifier​
  Repertoire = "C:\Documents and Settings\michel\dossier"​
  Fichier = Dir(Repertoire & "\*.xls")​
  'boucle sur les classeur du repertoire cible​
  Do While Fichier <> ""​
  Set Wb = Workbooks.Open(Repertoire & "\" & Fichier)​
  '-----------------------------------​
  'Attention , la procedure ne gère pas les erreurs si le nom des modules existe deja​
  'dans le classeur​
  With Wb.VBProject 'transfert l'USF et les modules dans les classeurs​
  .VBComponents.Import "C:\copieUSF.frm"​
  For i = 1 To 3​
  .VBComponents.Import "C:\copieModule" & i & ".bas"​
  Next i​
  End With​
  Wb.Close True​
  Fichier = Dir​
  Loop​
  Application.screenUpdating = True​
  End Sub​
• Déclencher une procédure evenementielle contenue dans un USF ,depuis une macro qui possede une variable
  
  le préfixe "Private" doit etre préalablement oté dans l'userForm​
  Private Sub Worksheet_Change(byVal Target As Range)​
  callByName userForm1, "commandButton" & Range("A1") & "_Click", vbMethod​
  End Sub​
• Executer une autre macro à partir d'une variable
  
  Dim sVar As String​
  'http://support.microsoft.com/kb/q108519/​
  sVar = "nomMacro"​
  Application.ExecuteExcel4Macro "RUN(""" & sVar & """)"​
• Exécuter une macro (contenue dans un module) d'un autre classeur ouvert
  
  Run "classeurTest.xls!Module1.macroTest"​
  Remarque :​
  Si le nom du classeur contient un caractere special ou un espace , le nom du classeur doit etre encadré par des quotes​
  Run "'Classeur-Test.xls'!Module1.macroTest"​
• Exécuter la macro Evenementielle "Workbook_Open" d'un autre classeur ouvert
  
  Run "classeurTest.xls!thisWorkbook.workbook_Open"​
• Désactiver la macro evenementielle workbook_Open lors d'une ouverture par macro
  
  Application.enableEvents = False​
  Workbooks.Open "C:\Documents and Settings\michel\dossier\leClasseur.xls"​
  'attention a bien reinitialiser la propriété d'activation des evenements :enableEvents​
  Application.enableEvents = True​

Créer dynamiquement un Label transparent dans une feuille Excel

Dim Obj As OLEObject​

Set Obj = Feuil1.OLEObjects.Add("Forms.Label.1")​

With Obj​

.Top = 141​

.Left = 360​

.Name = "leLabel"​

.Width = 119.25​

.Height = 75.75​

'.Object.Caption = ""​

.Object.backStyle = 0​

.shapeRange.Fill.foreColor.schemeColor = 65​

.shapeRange.Fill.Transparency = 1#​

End With​

• Numéroter les lignes d'une macro
  
  Ce lien n'existe plus​
• Lister les références actives dans le classeur contenant cette macro
  
  'necessite d'activer la référence "Microsoft Visual Basic for Applications Extensibility 5.3 "​
  Dim Ref As Reference​
  For Each Ref In thisWorkbook.VBProject.References​
  Debug.Print Ref.Name & " ---> " & Ref.fullPath​
  Next Ref​

Les chaines de caracteres

• Quelques exemples de fonctions qui permettent de manipuler les chaines de caracteres
  
  Len​
  ​
  Compter le nombre de caracteres dans une chaine​
  msgBox Len("mon texte") 'renvoie 9​
  
  
  Left​
  ​
  Renvoyer les 3 premiers caracteres d'un texte en partant de la gauche​
  msgBox Left("mon texte", 3) ' renvoie "mon"​
  
  
  Right​
  ​
  Renvoyer les 3 derniers caracteres d'un texte en partant de la droite​
  msgBox Right("mon texte", 3) ' renvoie "xte"​
  
  
  Mid​
  ​
  Extraire une chaine de caracteres à l'interieur d'un texte​
  (Dans cet exemple , 5 est la position du caractère qui marque le début de la partie à extraire​
  et 2 correspond au nombre de caractères à renvoyer )​
  msgBox Mid("mon texte", 5, 2) ' renvoie "te"​
  
  
  inStr​
  ​
  les arguments de la fonction : inStr(start, string1, string2, compare)​
  Renvoyer la position de la première occurrence d'une chaîne ("x" dans l'exemple) dans une autre chaîne.​
  msgBox inStr("mon texte", "x") 'renvoie 7​
  Le premier argument "start" (facultatif) permet de définir la position de départ de la recherche​
  msgBox inStr(1, "mon texte", "e") 'renvoie 6​
  msgBox inStr(7, "mon texte", "e") 'renvoie 9​
  La recherche est sensible à la casse si le dernier argument "compare" ( facultatif) est égal à 0​
  msgBox inStr(1, "mon texte", "X", 0) 'renvoie 0​
  msgBox inStr(1, "mon texte", "x", 0) 'renvoie 7​
  La recherche n'est pas sensible à la casse si le dernier argument "compare" est égal à 1​
  msgBox inStr(1, "mon texte", "X", 1) 'renvoie 7​
  msgBox inStr(1, "mon texte", "X", 1) 'renvoie 7​
  Lorsque le dernier argument "compare" est omis , la recherche est sensible à la casse​
  msgBox inStr(1, "mon texte", "X") 'renvoie 0​
  msgBox inStr(1, "mon texte", "x") 'renvoie 7​
  
  
  strReverse​
  ​
  Inverser l'ordre des caracteres dans une chaine​
  msgBox strReverse("mon texte")​
  
  
• Transformer Les minuscules d'une feuille en majuscule
  
  Sub Majuscule()​
  Dim Valeur As Range​
  For Each Valeur In Sheets("feuil1").usedRange​
  Valeur = uCase(Valeur) 'utiliser lCase pour tout mettre en minuscule​
  Next​
  End Sub​
• La premiere lettre du prenom en majuscule et le nom de famille en majuscule
  
  Le lien sur le forum XLD​
  Lien supprimé​
  Un autre lien sur le même sujet​
• Extraire les données séparées par un espace , dans une chaine de caractères
  
  Sub premiereDonnee()​
  Dim Tableau() As String​
  Tableau = Split("123 azerty 56", " ")​
  msgBox Tableau(0)​
  End Sub​
  Sub derniereDonnee()​
  Dim Tableau() As String​
  Tableau = Split("123 azerty 56", " ")​
  msgBox Tableau(UBound(Tableau))​
  End Sub​
• Extraire des mots en fonction de leur position dans la phrase
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Extraction de tous les mots d'une cellule
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Extraire les donnees d'une cellule et les trier par ordre alphabetique
  
  Le lien sur le forum XLD​
• Remplacer les virgules par des points
  
  Sub remplacerCaracteres()​
  Dim Cell As Variant​
  For Each Cell In Selection​
  Cell.Value = Application.Substitute(Cell.Value, ",", ".")​
  Next Cell​
  End Sub​
• Vérifier si un mot existe dans le dictionnaire Office
  
  Sub controleDicoOffice()​
  Dim Valeur As Boolean​
  Valeur = Application.checkSpelling("Michel", , False)​
  msgBox Valeur​
  End Sub​
• Extraire toutes les phrases d'un texte , en fonction de la ponctuation
  
  Le lien sur le forum XLD​
• Extraire des zones de texte séparées par des tirets , en tenant compte des mot composés
  
  Le lien sur le forum XLD​
• Contrôle si un mot est un palindrome( qui s'épelle de la même façon dans les deux sens)
  
  Dim leMot As String​
  leMot = "radar"​
  If leMot = strReverse(leMot) Then msgBox "Il s'agit d'un palindrome"​
• Inverser l'ordre des caractères dans une chaine
  
  msgBox strReverse("le forum xld")​
• La fonction strConv pour convertir une chaine au format spécifié
  
  Les types de format :​
  vbUpperCase : 1 Convertit la chaîne en majuscules.​
  vbLowerCase : 2 Convertit la chaîne en minuscules.​
  vbProperCase : 3 Convertit la première lettre de chaque mot de la chaîne en majuscule.​
  vbUnicode : 64 Convertit la chaîne en Unicode à l'aide de la page de code par défaut du système.​
  vbFromUnicode : 128 Convertit la chaîne Unicode dans la page de code par défaut du système.​
  Exemple pour transformer une chaine en majuscules :​
  msgBox strConv("le forum xld", vbUpperCase)​
• Supprimer tous les espaces dans la colonne A
  
  Sheets("Feuil1").Columns(1).Replace " ", ""​
• Supprimer les caracteres non imprimables dans la feuille active
  
  For Each Cell In activeSheet.usedRange​
  Cell.Value = Application.worksheetFunction.Clean(Cell.Value)​
  Next​
• Supprimer tous les espaces superflus à l'exception des espaces simples entre les mots
  
  L'équivalent de la fonction SUPPRESPACE​
  Dim Cell As Range​
  For Each Cell In activeSheet.usedRange​
  Cell = Application.worksheetFunction.Trim(Cell)​
  Next​
• Remplacer le caractère guillemet " par la lettre A, dans une chaine de caracteres (strVariable)
  
  msgBox Application.worksheetFunction.Substitute(strVariable, Chr(34), "A")​
• Utiliser la librairie Microsoft VBSCRIPT REGULAR EXPRESSIONS (une démo de Caféine adaptée par michel_M)
  
  La source :​
  http://cafeine.developpez.com/access/tutoriel/regexp/​
  Ce fichier n'existe plus​
• Scinder des phrases longues sans couper les mots
  
  Cet exemple coupe et remet en forme les longues requetes SQL par des créations de retours à la lignes. Lorsqu'une chaine atteint 80 caractères, la procédure effectue un retour à la ligne à la fin du mot.​
  Cible = Requete​
  Requete = ""​
  For i = 1 To Len(Cible)​
  X = inStr(80, Cible, " ")​
  If X = 0 Then​
  Chaine = Cible​
  Requete = Requete & """" & Chaine & """"​
  Exit For​
  End If​
  Chaine = Mid(Cible, 1, X)​
  Requete = Requete & """" & Chaine & """ & _" & vbCrLf​
  Cible = Mid(Cible, Len(Chaine) + 1)​
  Next​
  Debug.Print Requete​

Les modules de classse

• Un ditacticiel et des exemples créés par Emcy
  
  Le lien dans la zone de téléchargement​
  Les fichiers à télécharger​
• Des menus flottants personnalisés dans un userForm : une démo de Ludo
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Remplacement automatique des points par des virgules dans les Textbox d'un USF : une démo de Didier
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Action sur des Labels dans un Userform : une démo de Ti
  
  Lien supprimé​
• Eviter qu'un autre fichier Excel soit ouvert ou créé pendant que vous utilisez votre application.
  
  Une démo de Stephane​
  Le lien sur le forum XLD​
• Gérer plusieurs graphiques dans une feuille : Une demo de Zon
  
  Lister les graphiques de la feuille​
  Déclencher une action lors du clic dans un des graphiques​
  Récupérer l'adresse des series​
  Lien supprimé​
• Récupérer le nom des labels lors du passage de la souris sur chacun d'entre eux
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Colorier les cellules au passage de la souris : une démo de Didier , myDearFriend
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Gérer des commandButton créés dynamiquement : une démo d'Hervé
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Gérer les Glisser Déplacer dans des listBox : une démo de Carlos et Hervé
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Créer une Classe pour des objets placés dans une feuille (exemple de textbox) .
  
  'A placer dans un module de classe nommé "Classe1"​
  Option Explicit​
  Public withEvents txtBx As MSForms.textBox​
  'exemple pour gerer l'evenement doubleclic sur les objets type textBox dans la Feuil1​
  '(l'objet doir avoir le focus pour que l'evenement soit déclenché)​
  Private Sub txtBx_dblClick(byVal Cancel As MSForms.returnBoolean)​
  'cet exemple affiche le nom de l'objet double cliqué​
  msgBox txtBx.Name​
  End Sub​
  'A placer dans un module standard​
  Option Explicit​
  Public Collect As Collection​
  'A placer au niveau de thisWorbook pour que la classe soit initialisée lors de l'ouverture du classeur​
  Option Explicit​
  Private Sub Workbook_Open()​
  Dim Obj As OLEObject​
  Dim Cl As Classe1​
  Set Collect = New Collection​
  For Each Obj In Feuil1.OLEObjects 'boucle sur les objets de la Feuil1​
  If typeOf Obj.Object Is MSForms.textBox Then 'verifie s'il s'agit d'un Textbox​
  Set Cl = New Classe1​
  Set Cl.txtBx = Obj.Object​
  Collect.Add Cl​
  End If​
  Next Obj​
  End Sub​
• Gérer une série de Checkbox placés dans une feuille: une démo de Myta
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Gérer le déplacement des textBox (dans la feuille de calcul) avec les flèches de déplacement: Encoe une démo de Myta
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Comment utiliser une classe dans un projet VBA autre que celui dans lequel il est déclaré
  
  Le lien sur le site Microsoft​
• Manipuler des objets créés dynamiquement dans un Userform
  
  Cet exemple permet :​
  D'ajouter plusieurs Labels dynamiquement dans un Frame en parametrant la couleur et le symbole affiché.​
  Déplacer les Labels.Un 1er clic sur un objet de la zone de dessin permet de le déplacer (par mouseMove).Conseil : Ne déplacez pas trop vite le curseur de la souris. Un 2eme clic désactive le déplacement .​
  Zoomer/Dézoomer sur les labels par doucle clic sur le Label .​
  Supprimer les Labels de façon sélective.​
  Sauvegarder les parametres des labels dynamiques dans un fichier XML , afin de pouvoir y revenir plus tard sans perdre la mise en forme (Nom , Position , Dimension , Texte, Couleur de texte, Taille des caracteres) .Le fichier xml est enregistré dans le meme répertoire que ce classeur .​
  Charger dans l'USF les parametres contenus dans le fichier xml .​
  Le lien sur le forum XLD​
  Lien supprimé​
• Gérer le changement de focus pour des textBox placés dans des Frames
  
  Ce lien n'existe plus​

Si vous constatez des erreurs dans la page n'hesitez pas à m'en faire part .
Toutes vos idees sont les bienvenues .
Michel , Mise à jour le 15 Septembre 2006