[REF] Wiki Page 8 de MichelXld

MichelXld

XLDnaute Barbatruc
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.​




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​
  • 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
  • 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 myCombo_Object​
    .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
  • 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
    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
    Lien supprimé
  • Jouer un son Wave inséré dans la feuille , lors de l'ouverture du classeur
    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
  • 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
  • Récuperer la donnée affichée dans un Combobox formulaire ( aussi appelé "Zone Combinée" ou "Drop Down")
  • 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
  • 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
  • Supprimer tous les liens hypertextes d'une feuille
  • 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
  • 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)
    Lien supprimé
  • Auditer les liens hypertextes d'un classeur . Une démo de Didier (myDearFriend)
    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
    Lien supprimé
  • Les codes couleurs : équivalence RGB , Long , Hex
    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
  • 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
  • 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
  • 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
  • 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
  • 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
  • Ajouter par macro une référence manquante
    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
  • Repérer dans un répertoire tous les classeurs qui contiennent des macros
    une procédure de Didier myDearFriend​
  • Ajouter dynamiquement un Progressbar dans un userform
  • 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​
  • 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​
    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
    Lien supprimé
  • 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
    Lien supprimé
  • Extraction de tous les mots d'une cellule
    Lien supprimé
  • Extraire les donnees d'une cellule et les trier par ordre alphabetique
  • 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
  • Extraire des zones de texte séparées par des tirets , en tenant compte des mot composés
  • 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 :​
    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
  • Des menus flottants personnalisés dans un userForm : une démo de Ludo
    Lien supprimé
  • Remplacement automatique des points par des virgules dans les Textbox d'un USF : une démo de Didier
    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​
  • 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
    Lien supprimé
  • Colorier les cellules au passage de la souris : une démo de Didier , myDearFriend
    Lien supprimé
  • Gérer des commandButton créés dynamiquement : une démo d'Hervé
    Lien supprimé
  • Gérer les Glisser Déplacer dans des listBox : une démo de Carlos et Hervé
    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
    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
    Lien supprimé
  • Comment utiliser une classe dans un projet VBA autre que celui dans lequel il est déclaré
  • 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 .​
    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
 
Dernière modification par un modérateur:

Discussions similaires

Statistiques des forums

Discussions
311 541
Messages
2 080 545
Membres
101 238
dernier inscrit
frbhbkesvbrvjb754