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

Lien vers la wiki page 1 :Les feuilles , Les graphiques , Les images , Les propriétés des classeurs , Les sauvegardes , Les formes automatiques , Aleatoire , Les barres d'outils et les barres de menus , Les boites de dialogues intégrées , Les classeurs .

Lien vers la wiki page 2 : Les userforms : Les Checkbox , Les Labels , Les combobox , Les Commandbutton , Les Listbox ,Les Multipages , Les Frames , Les Textbox , Les imagesList , Les Treeview , Les Listview , Les Images , Les Webbrowser , Les calendriers , Les progressbar , Les Spreadsheet , Les Chartspaces , Les commonDialog , Les MSFlexGrid.

Lien vers la wiki page 3 :Piloter d'autres applications depuis Excel , Piloter ( Word , Outlook , Power Point ) , Les fichiers texte

Lien vers la wiki page 4 : Les fonctions mathématiques et trigonométriques , Les impressions , Les temporisations , Les fonctions , Les evenements , Excel , Les cellules , Copier & Coller , Les dates et les calendriers , Les spécificités Macintosh, Générer des fichiers Flash , Open Office

Lien vers la wiki page 5 : Les formules Excel , Les audits de formules , Les répertoires et les fichiers .

Lien vers la wiki page 6 : Les doublons , Les tris et les filtres , Les variables , Piloter les fichiers fermés (Excel , Access ,les fichiers DBF) .

Lien vers la wiki page 7 : Les commentaires , La gestion des erreurs , L'aide en ligne Excel , Les recherches dans un classeur, Les tableaux , Les pages html et internet , Windows Media Player , Le PC et le systême d'exploitation ,Piloter Flash , les types de boucles.

Lien vers la wiki page 8 : Piloter MSN Messenger et Windows Messenger , Les objets dans le feuille , Les liens hypertextes , Les formats , Visual basic editor , Les chaines de caractères , Les modules de classe.

Lien vers la wiki page 9 : Les mises en forme conditionnelles , Les Tableaux et graphiques Croisés Dynamiques , Gérer les fichiers XML depuis Excel , Piloter Open Office depuis Excel.

Lien vers la wiki page 10 : Le Publipostage Word / Excel.

Lien vers la wiki page 11 : Utiliser la librairie Windows Image Acquisition Automation Library v2.0 depuis Excel.

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

  Visualiser la macro

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

  Le fichier zippé

• Débuter : comment insérer un commandButton dans une feuille

  Le fichier zippé

• 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.textB ox.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.combo Box.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

  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").Dele te

• 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

  Le fichier zippé

• 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

  Le fichier zippé

• Jouer un son Wave inséré dans la feuille , lors de l'ouverture du classeur

  Le lien sur le forum XLD

  Le fichier zippé

• 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

  Le fichier zippé

• 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 )

  Le fichier zippé

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

  Le fichier zippé , une démo de myDearFriend

• Les codes couleurs : équivalence RGB , Long , Hex

  Le lien sur le forum XLD

  Le fichier zippé

• 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()

  'http://www.excel-downloads.com/forums/2-167924-lister-les-polices.htm

  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()

  'http://www.excel-downloads.com/forums/2-95108-transfert-de-correction-automatique.htm%%% 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).codeModul e

  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).codemodul e.countOfLines

  For i = 1 To x

  Cells(Ajout + i, 1) = thisWorkbook.VBProject.VBComponents(Msg).codemodul e.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).codemodul e

  With Mdl

  For Y = 1 To .countOfLines

  Cible = activeWorkbook.VBProject.VBComponents(Mdl).codemod ule.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).codemod ule.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").cod eModule

  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").cod emodule

  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").co deModule

  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).co deModule

  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).cod emodule.countOfLines

  For i = 1 To x

  Ligne = Workbooks(Fichier).VBProject.VBComponents(Msg).cod emodule.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").E xport "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

  Visualiser la macro

• 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

  Le fichier zippé

  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

  Le fichier zippé

• Extraction de tous les mots d'une cellule

  Le lien sur le forum XLD

  Le fichier zippé

• 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(strVariab le, 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/

  Le fichier zippé

• 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

  Le fichier zippé

• Remplacement automatique des points par des virgules dans les Textbox d'un USF : une démo de Didier

  Le lien sur le forum XLD

  Le fichier zippé

• Action sur des Labels dans un Userform : une démo de Ti

  Le fichier zippé

• 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

  Le fichier zippé

• Récupérer le nom des labels lors du passage de la souris sur chacun d'entre eux

  Le lien sur le forum XLD

  Le fichier zippé

• Colorier les cellules au passage de la souris : une démo de Didier , myDearFriend

  Le lien sur le forum XLD

  Le fichier zippé

• Gérer des commandButton créés dynamiquement : une démo d'Hervé

  Le lien sur le forum XLD

  Le fichier zippé

• Gérer les Glisser Déplacer dans des listBox : une démo de Carlos et Hervé

  Le lien sur le forum XLD

  Le fichier zippé

• 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

  Le fichier zippé

• 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

  Le fichier zippé

• 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

  Le fichier zippé

• Gérer le changement de focus pour des textBox placés dans des Frames

  Visualiser la macro

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