Problème : quelle part dans le classeur, se trouve une cellule nommée BUDGET
contenant une dotation budgétaire qui doit périodiquement être mise à jour. Une boîte
de dialogue doit permetttre de rajouter les dotations complémentaires.Le lancement sera
fera via un bouton auquel sera affectée cette macro.
Macro
Commentaires
Sub Dotation()
Dim Message, Title As String
Dim MaValeur
Message = "Montant de la dotation "
Title = "S&W"
MaValeur = InputBox(Message, Title)
If IsNumeric(MaValeur) = False Then
MsgBox "le montant n'est pas numérique !"
End
End If
Range("BUDGET").Value = MaValeur + _ Range("BUDGET").Value
End Sub
'Déclaration des variables
' Message et titre de l'InputBox
' prend la dotation via une boite de dialogue
'controle de l'aspect numérique
'affectation du resultat à la cellule nommée BUDGET
Remarques : la ligne
Range("BUDGET")... vous montre comment utiliser une cellule nommée dans le
cadre d'une procédure VBA. Comme les noms sont inclus dans le classeur, il n'y a pas
besoin de spécifier la feuille contenant la cellule nommée BUDGET
Atteindre une cellule nommée sur une autre feuille
Problème : Sélectionner une
cellule nommée "Client" se trouvant sur une autre feuille que la feuille active
Macro
Commentaires
Sub AtteindreClient() Application.Goto "Client"
End Sub
'Raccourci pour Range("Client")
Remarques : L'utilisation de
cette syntaxe évite le Sheets("Feuil").select
[Client].select
Format Pour Mille
Problème : Si le sigle % est disponible au clavier, il n'en est pas de même du
sigle qui se fait par la combinaison de ALTGR + 0137
Macro
Commentaires
Sub PourMille()
Dim Cellule As Range
For Each Cellule In Selection
Cellule = Cellule * 1000
Cellule.NumberFormat = "0.00"
Next
End Sub
'Déclaration des variables
'Boucle sur toutes mes cellules de la selection
'On multiple par mille chaque cellule
'On applique le format
Remarques : du fait de la
multiplication , les résultats ne seront valables qu'avec le format utilisé
Faire des opérations dans une
zone sélectionnée
Problème : Convertir les valeurs sélectionnées à la souris en Euros
Macro
Commentaires
Sub Euros()
Dim Cellule As Range
For Each Cellule In Selection
Cellule.Value = Cellule.Value / 6.55957
Next
End Sub
'Déclaration des variables
'Boucle sur toutes mes cellules de la selection
'On divise par 6.55957
Remarques : La boucle For Each
... In Selection
Recopier
des valeurs de cellules dans une autre feuille
Problème : Supposons 2 valeurs sur la Feuil1(ici en A4 et C4) que nous voulons
recopier sur la 1ère ligne vide de la Feuil2 dans les colonnes A et B
Macro
Commentaires
Sub RecopieCellule1()
Dim Ligne As Long
Ligne = Sheets("Feuil2").Range("a65536").End(xlUp).Row + 1
With Sheets("Feuil1")
Sheets("Feuil2").Cells(Ligne, 1).Value = .Range("a4").Value
Sheets("Feuil2").Cells(Ligne, 2).Value = .Range("c4").Value
Union(.Range("a4"), .Range("c4")).ClearContents
End With
End Sub
'Déclaration des variables
'Récupération du numéro de la dernière ligne vide
'Avec feuil1, de façon à éviter de retaper plusieurs fois Sheets("Feuil1")
'recopie de la 1ère cellule
'recopie de la 2ème cellule
'effacement des cellules sources
Remarques : Pour trouver la
dernière ligne, nous partons de la ligne 65536 (la dernière) et nous remontons, la
ligne trouvée sera la 1ère remplie en partant du bas, donc nous rajoutons +1 pour
arriver sur la 1ère vide.
Le With sheets("feuil1"), nous permet de ne le taper qu'une seule fois,
à noter, en ce cas le . (point) qui précède le range("a4") ou c4 Union permet de réunir plusieurs cellules et de leur appliquer un même
traitement (ici l'effacement)
Une autre approche consiste
à recopier les informations systématiquement sur la ligne 2 de façon à avoir en haut
de l'écran les dernières informations et non celles d'il y a 6 mois...
Macro
Commentaires
Sub RecopieCellule2()
Sheets("Feuil2").Rows("2:2").Insert
Sheets("Feuil2").[a2:b2] = Array([a4], [c4])
Union([a4], [c4]).ClearContents
End Sub
'insertion d'une nouvelle ligne 2
'recopie
'effacement de la saisie
Remarques : Cette macro, très
abrégée ne fonctionnera que si elle est lancée de la feuil1, les raccourcis [a4]
et [c4] n'étant pas précisées, ce sont ceux de la feuille active.
la notation [a4] n'est pas égale à la notion de Range (plage de
cellule) mais correspond à Evaluate (voir Aide VBA). Considerez-le présentement
comme un raccourci de saisie, certes pratique, mais, moins fiable que le Range Array : ici, permet de définir un tableau pour les cellules de départ (car,
elles ne sont pas l'une à côté de l'autre). Ce tableau a le même nombre d'éléments
que la zone de réception
Enfin, supposons que nous n'avons
pas 2 éléments à recopier, mais 25.... Les lignes VBA seraient un peu plus dures à
construire et surtout à corriger 6 mois après. Une solution simple consiste à recopier
sur une ligne éventuellement masquée de la Feuil1, les informations dans l'ordre voulu
et qui seront transférées sur la feuil2.
Par exemple, sur la Feuil1, nous utilserons la ligne 35. En A35, nous saisissons =A4, B35,
=C4, en C35, =MOIS(D5), en D35, =C10/6.55957 .... Et pour faciliter, la macro, nous
nommerons au préalable, l'ensemble des cellules variables (c'est à dire, contenant des
informations saisies par l'utilisateur) par un nom par exemple ZNE.
L'ensemble de la macro devient :
Macro
Commentaires
Sub RecopieCellule3()
Sheets("Feuil2").Rows("2:2").Insert
Sheets("Feuil2").Range("a2:y2").Value = _
Sheets("Feuil1").Range("a35:y35").Value
Range("ZNE").ClearContents
End Sub
'Insertion de lignes
'recopie des informations stockées sur la ligne 35
'Effacement de la Zone (informations saisies par l'utilisateur)
Remarques : La notation étant
complète, cette macro restera fiable et est facilement modifiable. Les noms étant
attribués, par défaut, au classeur, il n'est pas nécessaire de préciser la feuille
d'origine.
Le petit signe _ (souligné) précédé et suivi d'un espace, permet de dire que la ligne
d'instruction continue en dessous. La macro est ainsi plus facile à lire.
Créer un compteur qui
s'incrémente à chaque ouverture du fichier
Macro
Commentaires
avec une cellule nommée "compteur" dans le
classeur soit d'un module standard
sub auto_open()
Range("compteur") = Range("compteur") + 1
end sub
'le nom, ici, est
important
'on rajoute +1 à la valeur de la cellule compteur
avec une cellule nommée "compteur" dans le
classeur soit dans le module Thisworbook de Vba (excel97 et +)
Private Sub Workbook_Open()
Range("compteur") = Range("compteur") + 1
End Sub
'le nom correspond à
l'évenement
Avant Excel 97, nous avions uniquement, les procédures Sub
auto_open (à l'ouverture) et Sub auto_close (à la fermeture) pour paramètrer les
évenements.
Mettre la 1ère lettre en
Majuscule
Problème : Transformer le texte des cellules sélectionnées en
mettant la 1ère lettre en majuscule et le reste en Minuscule.
Macro
Commentaires
Sub Majuscule1Lettre()
On Error Resume Next
Dim Cellule As Range
For Each Cellule In Selection
Cellule = UCase(Left(Cellule, 1)) & _
LCase(Right(Cellule, Len(Cellule) - 1))
Next
End Sub
'Si erreur, on continue
'Boucle sur toutes mes cellules de la selection
'Conversion
Remarques : UCase(Left(Cellule,
1)) & LCase(Right(Cellule, Len(Cellule) - 1)) : Mettre en majuscule (UCase) la 1ère
lettre à Gauche (Left) et en minuscule (LCase) tous les caractères -1 (Len(Cellule) - 1)
à partir de la droite (Right). Concerne uniquement la 1ère lettre du 1er mot
Sub Majuscule2Lettre()
On Error Resume Next
Dim Cellule As Range
For Each Cellule In Selection
Cellule = WorksheetFunction.Proper(Cellule)
Next
End Sub
'Si erreur, on continue
'Boucle sur toutes mes cellules de la selection
'Conversion
Remarques : Ici, est utilisée
la fonction NOMPROPRE (Proper) et concerne tous les mots
Selection en cours : une ou
plusieurs cellules ?
Macro
Commentaires
Sub CompteCellule()
If Selection.Count > 1 Then
MsgBox "il y a " & Selection.Count _
& " cellules selectionnées"
Else: MsgBox "il n'y a qu'une cellule sélectionnée"
End If
End Sub
'Test du nombre
'Si supérieur à 1, affiche le nombre
'Sinon, affiche l'autre message
Remarques : l'intérêt est
d'utiliser la notion de Selection.Count
Rechercher une valeur dans
une cellule et récupérer l'adresse
Problème : Nous cherchons un élément dans la feuille dont nous souhaitons
récupérer l'adresse.
Macro
Commentaires
Sub RechercheAdresse()
On Error Resume Next
Dim Recherche
Err = 0
Recherche = InputBox("rechercher quoi ?")
If Err <> 0 Then
MsgBox Recherche + " pas trouvé !"
Else: MsgBox Recherche + " trouvé en " + ActiveCell.Address
End If
End Sub
'Si erreur, on continue
'Mise à 0 de l'erreur
'Affiche une boîte demandant la valeur cherchée
'Lancement de la commande recherche dans les valeurs des cellules, et sélection du
résultat
'S'il y a erreur
'Alors, pas trouvé
'Si trouvé, affiche l'adresse
Remarques : Cells.find doit
être associé à une gestion de l'erreur
Trier un tableau en lignes et non pas en
colonnes
Problème : Trier un tableau de plusieurs 100 de lignes sur 10 colonnes (A à J) mais
les trier en lignes (les valeurs les plus petites dans la colonne A...). Cela correspond
au Menu Données - Trier - Options de Gauche à Droite. Le but est d'automatiser pour
l'ensembles des lignes.
Macro
Commentaires
Sub TriEnLigne()
Application.ScreenUpdating = False
Dim Ligne As Long
For Ligne = 2 To Range("a1").End(xlDown).Row
Range("a" & Ligne & ":J" & Ligne).Sort _
key1:=Range("a" & Ligne), Order1:=xlAscending, _
header:=xlGuess, ordercustom:=1, MatchCase:=False, _
Orientation:=xlLeftToRight
Next Ligne
End Sub
'Empêche le rafraîchissement de l'écran
'Déclaration des variables
'Récupère la dernière ligne (row) et 'commence la boucle à la ligne 2
'Fait le tri ligne par ligne de gauche à
'droite
'Change de ligne
Note : La récupération du numéro
de la dernière ligne Range("a1").End(xlDown).Row est très classique. Mais,
cette méthode de tri de gauche à droite est peu connue.
Diviser un nombre par X et reporter les résultats intermédiaires et
final (calcul des dépréciations pour ordre)
Range("H2").FormulaR1C1 = FS.Range("B13").Value - ValeurDerniere
End If
Loop
'Déclaration de variables
et affectation
'Début de boucle
'insertion d'une ligne
'mise a jour année dépréciation
'Incrémentation des compteurs
' test sur la derniere année
'saisie de la dépréciation sur 1 année avec arrondi du calcul (Round)
'Mis à jour de la valeur depreciée
'saisie du cumul deprecié
'saisie du reste à reste à deprecier
'si dernière année
'Saisie de la depreciation
'mis à jour de la dernière valeur (gestion des arrondis)
'Saisie de la dernière dépréciation
'Saisie du reste (contrôle du solde à 0)
'fin condition
'Retour au début de boucle
l'intérêt de cette procédure est de gérer les restes de
division pour obtenir un calcul exact sur la dernière valeur : voir l'utilisation des
variables ValeurDeprecie et ValeurDerniere
Faire un chronomètre sous Excel
macro
commentaires
Private Sub Worksheet_BeforeRightClick(ByVal
Target As Range, Cancel As Boolean)
Static c As Long
Cancel = True
If IsEmpty(Cells(1, 1)) Then c = 0
c = c + 1
Cells(c, 1) = Now
Cells(c, 2) = Now - Cells(1, 1)
If c <> 1 Then Cells(c, 3) = Now - _ Cells(c, 1).Offset(-1, 0)
End Sub
'L'évenement est géré
par le clic droit, il peut être affecté aussi au double clic gauche
' Déclaration de la variable en static - garde la mémoire
'désactivation de l'apparition du menu clic droit
'test sur la cellule A1 si elle vide alors la variable est à 0
'incrémentation de la variable de façon à déplacer la cellule
active
' affectation des valeurs cellule A c : l'heure actuelle , cellule B
c : différence par rapport à l'heure de départ
'test de la 1ère ligne, pour remplir la colonne C (calcul entre les 2 temps consécutifs
Il va de soi, afin que cette macro s'exécute correctement
que si les 3 premières colonnes sont formatées en hh:mm:ss
Télécharger le classeur : chrono.xls
Cela illustre les possibilités de static pour une variable à condition de prévoir les
conditions de sa remise à zéro (ici, l'absence de données en cellule A1)
Supprimer des lignes en
fonction de la valeur trouvée dans la 1ère colonne
Problème : Supprimer les lignes
entières lorsque dans la colonne A se trouve telle ou telle valeur.
Tout d'abord : la version classique
macro
commentaires
Sub SuppLigne()
Application.ScreenUpdating = False
For i = Range("a65536").End(xlUp).Row To 1 Step -1
If Cells(i, 1).Value = "toto" Then _
Cells(i, 1).EntireRow.Delete
Next
End Sub
'Empêche le rafraichissement de l'écran
'Début de boucle, on récupère le numéro de la dernière ligne occupé en colonne A et
on remonte jusqu'à 1 ligne après ligne
'Test sur la valeur et si vrai suppression de la ligne
le fait de remonter (step -1) de la fin vers le début permet
que lorsque la valeur test est trouvée sur 2 lignes, l'une en-dessous de l'autre, les 2
lignes soient effacées, alors qu'une seule le serait si nous avions bouclé du haut vers
le bas
Dans le cas de fichier très long,
cette macro peut être lente, d'où
la version suggerée par Denis Michon :
macro
commentaires
Sub SuppLigne2()
Application.ScreenUpdating = False
For i = Range("a65536").End(xlUp).Row To 1 Step -1
If Cells(i, 1).Value = "toto" Then Cells(i, 1).ClearContents
Next
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
'Maintenant, on efface seulement la valeur test (plus rapide)
'On atteint les cellules vides qu'on efface en une seule fois
La rapidité sur un gros fichier est manifeste, l'effacement
des valeurs et la suppression des lignes en une seule fois sont plus rapide que la
suppression individuelle de chaque ligne.
Se déplacer en lignes et en colonnes -
création d'un calendrier entre 2 dates
Faire un calendrier entre 2 dates
en choisissant la cellule de départ et en changeant de colonne à chaque mois, les
différents mois étant séparés par une colonne vide.
La base de départ de cette macro provient du site http://perso.wanadoo.fr/frederic.sigonneau
macro
commentaires
Sub CalendrierLudoBis()
Dim Debut, Fin, Jour As Date
Dim Cellule As Range
Dim Mois, Ligne, Colonne, LigneDepart As Long
On Error Resume Next
Debut = CDate(InputBox("Date de départ du Calendrier"))
Fin = CDate(InputBox("Dernière date du Calendrier"))
Mois = Month(Debut)
If Err <> 0 Then Exit Sub
Set Cellule = Application.InputBox _
("Sélectionnez la cellule où commence le calendrier", _ Type:=8)
If Err <> 0 Then Exit Sub
LigneDepart = Cellule.Row
Ligne = Cellule.Row: Colonne = Cellule.Column
For Jour = Debut To Fin
If Month(Jour) <> Mois Then
Ligne = LigneDepart
Colonne = Colonne + 2
If Mois = 12 Then
Mois = 1
Else
Mois = Mois + 1
End If
End If
Cells(Ligne, Colonne).Value2 = Jour
'Activation de la gestion d'erreur
'Récupération et transformation en date des valeurs récupées par les boîtes de
dialogues dans les variables
'Initialisation du mois de départ
'Si erreur (pas date), on sort
'Sélection de la cellule de départ
' à noter le type:=8 (cellule)
'Si erreur (pas cellule), on sort
'Récupération de la ligne de départ
'Initialisation de la ligne et colonne en cours
'Début de boucle entre le 1 et le dernier jour
'Contrôle si le jour en cours n'appartient pas au même mois que le jour de départ
'Si mois différent, retour à la ligne de départ
' et changement de colonne (+2)
'Avant de réinitialiser la variable mois, test pour savoir si le mois en cours est
décembre
'En ce cas, le mois devient janvier
'Sinon, le mois devient le suivant
'La cellule en cours prend la valeur Jour
'La cellule est formatée en date particulière
'Puis, on change de ligne
'On change de Jour
Télécharger le classeur : Calendrier1.xls
A noter : la gestion d'erreur : on error resume next et if err<>0 pour sortir de la
procédure,
le déplacement à chaque changement de mois, de colonne par le test du mois en cours et
la récupération de la ligne de départ.
Mise en forme conditionnelle d'un graphique (si
les chiffres sont >200, rouge sinon bleu)
Pour un histogramme :
macro
commentaires
Sub FormatConditionnelGraphique()
For c = 1 To ActiveChart.SeriesCollection.Count
For d = 1 To ActiveChart.SeriesCollection(c).Points.Count
If ActiveChart.SeriesCollection(c).Points(d). _
HasDataLabel = False Then test= 1
ActiveChart.SeriesCollection(c).Points(d). _
HasDataLabel = True
rep =ActiveChart.SeriesCollection(c).Points(d). _ DataLabel.Text
If CDbl(rep) > 200 Then
ActiveChart.SeriesCollection(c).Points(d).Interior. _ ColorIndex = 3
Else
ActiveChart.SeriesCollection(c).Points(d).Interior. _ ColorIndex = 17
End If
If test = 1 Then ActiveChart.SeriesCollection(c).Points(d). _ HasDataLabel =False
Next d
Next c
End Sub
'Compte le nombre de séries
'Compte le nombre de points
'Teste la présente des étiquettes sur le graphs
'Affiche les étiquettes
'Récupère les informations des étiquettes
'Convertit l'étiquette en nombre et fait le test
'Suivant le résultat, change la couleur
'remet dans l'état initial le graphique
l'intérêt de cette procédure est qu'elle ne teste pas les
cellules à l'origine du graph, mais qu'elle travaille exclusivement sur le texte des
étiquettes du graph.
Mettre les étiquettes en % dans un histogramme empilé
Problème : Mettre des
étiquettes représentant le pourcentage de chaque part pour des histogrammes empilés
12/01
Macro
Commentaires
Sub PourcentageHistogramme()
For c = 1 To ActiveChart.SeriesCollection.Count
For d = 1 To ActiveChart.SeriesCollection(c).Points.Count
ActiveChart.SeriesCollection(c).Points(d).HasDataLabel = True
total = total + _ CDbl(ActiveChart.SeriesCollection(c).Points(d).DataLabel.Text)
Next d
For e = 1 To ActiveChart.SeriesCollection(c).Points.Count
Valeur = _
CDbl(ActiveChart.SeriesCollection(c).Points(e).DataLabel.Text)
Resultat = Format(CDbl(Valeur) / total, "0.00%")
ActiveChart.SeriesCollection(c).Points(e).DataLabel.Text
= _ Resultat
Next e
Next c
End Sub
compte le nombre de séries
compte le nombre le nombre de points dans la série
affiche les labels (valeur en texte)
Calcule le total de la série
Reprend les points de la série
Récupère la valeur de la série et la transforme en nombre
Calcul le rapport entre la valeur et le total et laffiche sous la forme de %
mais en texte
Affecte ce résultat au point de la série
Remarques : A noter :
la conversion de texte en nombre par CDbl. Le 0.00% doit être transformé en 0,00%
suivant le séparateur décimal installé sur votre poste.
Recopier x feuilles sur 1 seule feuille
Cette procédure mériterait d'être testée de façon plus approfondie. Elle recopie
sur la feuille1 toutes les autres feuilles du classeur :
Macro
Commentaires
Sub ReportFeuille()
Dim Ligne, Nombre As Long
Sheets(1).Range("A1").CurrentRegion.ClearContents
For Nombre = Worksheets.Count To 2 Step -1
Sheets(Nombre).UsedRange
Ligne = Sheets(Nombre).Range("a1") _
.SpecialCells(xlCellTypeLastCell).Row
Sheets(1).Rows("1:" & Ligne).EntireRow.Insert _ shift:=xlDown
Sheets(Nombre).UsedRange.Copy _ Destination:=Sheets(1).Range("a1")
Application.CutCopyMode = False
Next Nombre
End Sub
'Déclaration de variables
'Vide la feuille 1
'Compte le nombre de feuille et 'commence la boucle par la fin en 'remontant et s'arrête
à l'avant-dernière 'feuille
'Réinitialise les zones utilisées dans chaque 'feuille
'Récupère la dernière ligne de la dernière 'cellule utilisée
'Insère le nombre de lignes souhaité sur la 'feuille 1
'Copie les zones utilisées sur la feuille1, à
'partir de A1
'Terminer le copier-coller
'Change de feuille
Note : L'intérêt et (peut-être)
la limite de cette procédure est de faire appel à la notion de plage de cellules
utilisée UsedRange. Egalement, la boucle en arrière avec Step -1
Récupérer
le nom de la feuille activedans une variable
Macro
Commentaires
Sub NomFeuille()
Dim Nom As String
Nom = ActiveSheet.Name
MsgBox ("La feuille active s'appelle ") & Nom
End Sub
'Déclaration de variable
'Affectation de la variable
'Affichage