Sommaire
Excel Perfectionnement
Excel Graphique
Divers Excel
Excel Vba début
Complément VBA
Utilitaires
Gestion
(philosophie)
Gestion
(techniques)
Liens
Utilitaires en Vrac
Gfc Windows

écrivrez-moi !














 

 

 

Utilisation des cellules nommées

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

début                                         Sommaire

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

 

début                                         Sommaire

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é

début                                         Sommaire

 

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

début                                         Sommaire

 

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.

début                                         Sommaire

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.

début                                         Sommaire

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

début                                         Sommaire

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

début                                         Sommaire

 

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 ?")

Cells.Find(What:=Recherche,  LookIn:=xlValues).Activate


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

début                                         Sommaire

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.

début                                         Sommaire

Diviser un nombre par X et reporter les résultats intermédiaires et final (calcul des dépréciations pour ordre)

Extrait de l'application Immobilisations et inventaires v2.4

macro commentaires
Dim annee
Dim compteur
Dim duree
Dim ValeurDeprecie
Dim ValeurDerniere
compteur = FS.Range("B14").Value + 1
duree = FS.Range("B14").Value
annee = FS.Range("B5").Value
Do While compteur <> 0
Rows("2:2").Insert Shift:=xlDown
Range("A2").FormulaR1C1 = annee
annee = annee + 1
compteur = compteur - 1
If compteur > 0 Then
Range("F2").FormulaR1C1 = _ WorksheetFunction.Round(FS.Range("B13").Value / duree, 2)

ValeurDeprecie = ValeurDeprecie + Range("F2").Value
Range("G2").FormulaR1C1 = ValeurDeprecie
Range("H2").FormulaR1C1 = FS.Range("B13").Value - _ ValeurDeprecie
Else
Range("F2").FormulaR1C1 = FS.Range("B13").Value - _ ValeurDeprecie
ValeurDerniere = Range("F2").Value + ValeurDeprecie

Range("G2").FormulaR1C1 = ValeurDerniere

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

 

début                                         Sommaire

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)


début                                         Sommaire

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.


début                                         Sommaire

 

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

Cells(Ligne, Colonne).NumberFormatLocal = "jjj jj/mm/aa"

Ligne = Ligne + 1
Next Jour
End Sub

'Déclaration des variables


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


début                                         Sommaire

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.

début                                         Sommaire

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 l’affiche 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.

début                                         Sommaire

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

début                                         Sommaire

 

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

début                                         Sommaire