Excel par l'exemple

Macro commandes pour les pros

 


 

 

Exercices aidés et corrigés
Guides Excel et Internet Facile
Téléchargement
Trucs et Astuces
Applications Excel
Touches de raccourci
Liens

 

 

 

Ouvrir Word à partir d'Excel


Convertir des nombres en heures
Additionner les nombres contenus dans les cellules dont le texte est en bleu (ou rouge, ou vert, etc.)
Compter le nombre de cellules dont le fond est coloré en bleu (ou rouge, ou vert, etc.)
Une macro de conversion EURos- EURos et EURos-euros
Convertir des majuscules en minuscules
Convertir un nombre en lettres (fonctionne avec des EURos ou des EURos)
Ajouter le nom complet du classeur dans le pied de page (pour édition) de la feuille
Masque les lignes vides d'une sélection
Selection d'une plage de cellules à partir d'une cellule sélectionnée

 


Ouvrir Word à partir d'Excel

 

Voici le code de la macro à saisir :

Sub ouvrir_word()

Set ww = CreateObject("word.application")
ww.Visible = True
ww.documents.Add

End Sub


Convertir des nombres en heures

 

Comment transformer 15,5 en 15:30, ou comment transformer 12,3 en 12:18 ?

Il faut construire la macro suivante et l'appliquer à la zone préalablement sélectionnée dans la feuille de calcul :

Dans visual basic tapez le code :

Sub conversionheures()
Dim Answer As Long
For Each Cell In Selection
Cell.Value = (Cell.Value / 24)
Next
Selection.Numberformat = "[h]:mm"

End sub


Additionner les nombres contenus dans les cellules dont le texte est en bleu (rouge, vert, etc.)

 

Dans visual basic tapez le code suivant :

Sub sommeCouleurRougeText()
Dim Cellule As Range
Dim total As Variant
For Each Cellule In Selection
If Cellule.Font.ColorIndex = 5 Then
'5 est le code couleur du bleu
If IsNumeric(Cellule) Then total = total + Cellule.Value
End If
Next
MsgBox total
Range("G12") = total

End Sub

Vous pouvez remplacer le code couleur en changeant son numéro sur la ligne "if Cellule.font.ColorIndex = 5 Then" le 5 est à remplacer par le code couleur souhaité (voir tableau des couleurs ci-dessous).

Avant d'éxécuter la macro, sélectionnez la plage de cellule pour laquelle vous souhaitez obtenir le total.

Vous pouvez obtenir le même résultat en testant la couleur de fond de la cellule. Pour cela remplacer
"
if Cellule.font.ColorIndex = 5" par "If Cellule.Interior.ColorIndex = 5"


 

Compter le nombre de cellules dont le fond est coloré en bleu (rouge, vert, etc.)

Dans visual basic tapez le code suivant :

Sub NombredeCellulesbleues()
Dim Cellule As Range
Dim total As Variant
For Each Cellule In Selection
If Cellule.Interior.ColorIndex = 5 Then
'bleu
total = total + Cellule.Count
End If
Next
MsgBox "Il y a " & total & " Cellules bleues"
Range("A1") = total

End Sub

 

Vous pouvez remplacer le code couleur en changeant son numéro sur la ligne "if Cellule.Interior.ColorIndex = 5 Then 'bleu" le 5 est à remplacer par le code couleur souhaité (voir tableau des couleurs ci-dessous) ainsi que le message de la boîte de dialogue sur la ligne "MsgBox "Il y a " & total & " Cellules bleues""

Avant d'éxécuter la macro, sélectionnez la plage de cellule pour laquelle vous souhaitez obtenir un décompte.

Vous pouvez obtenir le même résultat en testant la couleur du texte. Pour cela remplacer
"
If Cellule.Interior.ColorIndex = 5" par "if Cellule.font.ColorIndex = 5"


Une macro de conversion de EURos vers EURo et d'euros vers EURos

 

Télécharger l'explication de la macro (format word 97 - 83ko) en cliquant ici


Convertir des majuscules en minuscules

 

Il faut créer une macro. Appuyer sur " Alt + F11 " afin de lancer Visual Basic Editor. Ouvrez le menu Insertion/Module et saisissez le listing ci-dessous.

 

Sub MinMaj()

Dim ChaineCellule As String

ChaineCellule = Selection.Value

ChaineCellule = Ucase(ChaineCellule)

Selection.Value = ChaineCellule

End Sub

 

Saisissez un texte en minuscule dans une cellule et lancez la macro. Vous pouvez aussi lui affecter un bouton dans la barre d'outils.


Convertir un nombre en lettres (fonctionne avec des EURos ou des EURos)

 

Il s'agit ici d'une fonction à créer. Cette fonction se présentera sous cette forme :

ChiffreEnLettre(A1;A2;A3)

Où :

A1 sera la cellule contenant le nombre à convertir,
A2 la cellule contenant le symbole monétaire (F pour EURos ou E pour EURo),
A3 la cellule contenant le coefficient de conversion (1 pour EURos, 6.55957 pour les EURo)

Télécharger le fichier exemple

Le code à recopier dans Visual Basic Editor (accessible par le menu "Outils - Macro - Visual Basic) est le suivant :

'---------------------------------------------

' Permet la conversion des valeurs en lettres

'---------------------------------------------

Function lireCentaine(ByVal Montant As Double) As String

Dim ChiffreLettre

Dim Centaine As Double

Dim Dizaine As Double

Dim T As String

Dim Chaine As String

'tableau de conversion des chiffres en texte

ChiffreLettre = Array("un", "deux", "trois", "quatre", "cinq", "six", _

"sept", "huit", "neuf", "dix", _

"onze", "douze", "treize", "quatorze", "quinze", _

"seize", "dix-sept", "dix-huit", "dix-neuf")

'recherche des centaines

Centaine = Int(Montant / 100)

 

Select Case Centaine

Case 0

Chaine = ""

Case 1

Chaine = "cent"

Case Else 'autres valeurs

Chaine = ChiffreLettre(Centaine - 1) & " cent"

End Select

 

Dizaine = Modulo(Montant, 100)

Select Case Dizaine

Case 0

T = ""

Case 1 To 19

T = ChiffreLettre(Dizaine - 1)

Case 20

T = "vingt"

Case 21

T = "vingt et un"

Case 22 To 29

T = "vingt " & ChiffreLettre(Dizaine - 21)

Case 30

T = "trente"

Case 31

T = "trente et un"

Case 32 To 39

T = "trente " & ChiffreLettre(Dizaine - 31)

Case 40

T = "quarante"

Case 41

T = "quarante et un"

Case 42 To 49

T = "quarante " & ChiffreLettre(Dizaine - 41)

Case 50

T = "cinquante"

Case 51

T = "cinquante et un"

Case 52 To 59

T = "cinquante " & ChiffreLettre(Dizaine - 51)

Case 60

T = "soixante"

Case 61

T = "soixante et un"

Case 62 To 69

T = "soixante " & ChiffreLettre(Dizaine - 61)

Case 70

T = "soixante-dix"

Case 71

T = "soixante et onze"

Case 72 To 79

T = "soixante " & ChiffreLettre(Dizaine - 61)

Case 80

T = "quatre vingts"

Case 81 To 89

T = "quatre vingt " & ChiffreLettre(Dizaine - 81)

Case 90 To 99

T = "quatre vingt " & ChiffreLettre(Dizaine - 81)

Case Else

T = "Erreur de conversion !"

End Select

If (Chaine & " " & T) = " " Then

lireCentaine = ""

Else

lireCentaine = LTrim(Chaine & " ") & T

End If

 

 

End Function

'-----------------

' Fonction Modulo

'-----------------

Function Modulo(ByVal Nombre As Double, ByVal Diviseur As Double) As Double

Modulo = Nombre - (Diviseur * Int(Nombre / Diviseur))

End Function

'-------------------

' Fonction Arrondir

'-------------------

Function Arrondir(ByVal ValeurArrondi As Double, ByVal NbreDeci As Integer) As Double

Arrondir = ValeurArrondi + (5 * 10 ^ -(NbreDeci + 1))

Arrondir = Int(Arrondir * 10 ^ NbreDeci) / 10 ^ NbreDeci

 

End Function

 

 

'---------------------

' Fonction principale

'---------------------

Function ChiffreEnLettre(ByVal Total As Double, ByVal Devise As String, ByVal Change As Double) As String

 

Dim Millions As Double

Dim Milliers As Double

Dim cent As Double

Dim decimales As Double

Dim T0 As String

Dim T1 As String

Dim T2 As String

Dim T3 As String

Dim Resultat As String

Dim T As String

Dim Devise1, Devise2, S1, S2 As String

 

'Pour éviter des erreurs de conversion, on arrondit la valeur d'entrée

Total = Arrondir(Total, 2)

 

'Si on calcule en EURos

If Devise = "E" Then

'MsgBox (Total)

Total = Arrondir((Total / Change), 2)

'MsgBox (Total)

End If

 

'-------------------------------------------

' On décompose le nombre en tranche de cent

' Ainsi pour 2465,45 on a :

' Milliers=2

' Cent = 465

' decimales 45

'------------------------------------------

Millions = Int(Modulo(Int(Total / 1000000), 1000))

Milliers = Int(Modulo(Int(Total / 1000), 1000))

cent = Int(Modulo(Total, 1000))

decimales = Arrondir((Modulo(Total * 100, 100)), 0)

 

'Y-a-t'il un s ?

'---------------

S1 = ""

S2 = ""

'MsgBox (Milliers)

'MsgBox (cent)

 

'If Milliers <= 1 Then S1 = "" Else S1 = "s"

If cent <= 1 Then

If Milliers < 1 Then

If Millions < 1 Then

S1 = ""

Else

S1 = "s"

End If

Else

S1 = "s"

End If

Else

S1 = "s"

End If

 

If decimales <= 1 Then S2 = "" Else S2 = "s"

'If Total <= 1 Then S1 = "" Else S1 = "s"

'MsgBox (S1)

' Choix de la devise

'-------------------

If Devise = "F" Then

Devise1 = " EURo" & S1

Devise2 = " centime" & S2

Else

Devise1 = " EURo" & S1

Devise2 = " cent" & S2 & " d'euro"

End If

'Total = InputBox("Entrer un nombre", "Conversion")

'MsgBox (Devise1)

'-------------------------------------------------------------------------

' La fonction lirecentaine permet de convertir chaque tranche en lettres

'-------------------------------------------------------------------------

T0 = lireCentaine(Millions)

T1 = lireCentaine(Milliers)

T2 = lireCentaine(cent)

T3 = lireCentaine(decimales)

'MsgBox ("D" & T2 & "F")

'MsgBox (cent)

If (T0 = "" And T1 = "" And T3 = "" And Right(T2, 5) = "cent ") Then

If cent > 100 Then T2 = RTrim(T2) & "s"

End If

If T0 <> "" Then

Resultat = T0 & " million "

If T1 = "" And T2 = "" And T3 = "" Then

Resultat = T0 & " million de"

End If

Else

Resultat = ""

End If

If T1 <> "" Then

If T1 = "un" Then

T1 = ""

End If

Resultat = Resultat & T1 & " mille "

Else

Resultat = Resultat & ""

End If

If T2 <> "" Then

Resultat = Resultat & T2 & Devise1

Else

If Resultat <> "" Then

Resultat = Resultat & Devise1

End If

End If

If T3 <> "" Then

If Resultat <> "" Then

Resultat = Resultat & " et " & T3 & Devise2

Else

Resultat = T3 & Devise2

End If

End If

 

 

'T = MsgBox(Resultat, vbOKOnly, "Résultat de la conversion")

ChiffreEnLettre = Resultat

End Function


 

'---------------- standard ADM version 9204
'
PleinEcran()
'
EcranNormal()
' AffichageA1()
' AffichageL1C1()
' Fige()
' VersToutEnHautAGauche
' AffichagePleinEcran
' SuperGrandEcran
' VersLeHaut
' VersLeBas
' VersLaDroite
' VersLaGauche
' ClasseurPrecedent
' ClasseurSuivant
' FeuilleSuivante
' FeuillePrecedente
' FiltreOuPasFiltre()
'
CentreSurPlusieursColonnes()
'
SePositionneSurRepertoireDuFichier() <----- intéressant !


Public FlagMessage As Integer


 

Sub PleinEcran()
' PleinEcran Macro
' Macro enregistrée le 21/01/99 par ADM
Application.DisplayFullScreen = True
End Sub


Sub EcranNormal()
' EcranNormal Macro
' Macro enregistrée le 21/01/99 par ADM
Application.DisplayFullScreen = False
ActiveWindow.DisplayHeadings = True
ActiveWindow.Zoom = 100
End Sub

 


Sub AffichageA1()
' AffichageA1 Macro
' Macro enregistrée le 21/01/99 par ADM
With Application
.ReferenceStyle = xlA1
End With
End Sub

 


Sub AffichageL1C1()
' AffichageL1C1 Macro
' Macro enregistrée le 21/01/99 par ADM
With Application
.ReferenceStyle = xlR1C1
End With
End Sub

 


Sub Fige()
' ' remplace une formule par sa valeur dans une cellule

 

Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

End Sub


Sub VersToutEnHautAGauche()
' VersToutEnHautAGauche - Macro enregistrée le 23/01/99 par ADM

 

Range("C10").Select
Range("B2").Select
Range("A1").Select

End Sub


Sub AffichagePleinEcran()
' AffichagePleinEcran Macro
' Macro enregistrée le 23/01/99 par ADM
Application.DisplayFullScreen = True
End Sub

 


Sub SuperGrandEcran()
' SuperGrandEcran Macro
' Macro enregistrée le 24/01/99 par ADM

 

Application.DisplayFullScreen = True
ActiveWindow.DisplayHeadings = False
ActiveWindow.Zoom = 75

End Sub


Sub VersLeHaut()
ActiveCell.Offset(-1, 0).Range("A1").Select
End Sub

 


Sub VersLeBas()
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

 


Sub VersLaDroite()
ActiveCell.Offset(0, 1).Range("A1").Select
End Sub

 


Sub VersLaGauche()
ActiveCell.Offset(0, -1).Range("A1").Select
End Sub

 


Sub QuadrillageMasque()

 

ActiveWindow.DisplayGridlines = False

End Sub


Sub QuadrillageAffiche()

 

ActiveWindow.DisplayGridlines = True

End Sub


Sub ClasseurPrecedent()

 

ActiveWindow.ActivatePrevious
FlagMessage = 1
SePositionneSurRepertoireDuFichier ' *

End Sub


Sub ClasseurSuivant()

 

ActiveWindow.ActivateNext
FlagMessage = 1
SePositionneSurRepertoireDuFichier' *

End Sub


Sub FeuilleSuivante()
On Error GoTo Fin '
ActiveSheet.Next.Select
Exit Sub
Fin:
Beep
End Sub

 


Sub FeuillePrecedente()
On Error GoTo Fin '

 

ActiveSheet.Previous.Select

Exit Sub
Fin:

Beep

End Sub


Sub FiltreOuPasFiltre()

 

Selection.AutoFilter

End Sub


Sub OùSuisJe()

 

MsgBox (ActiveWorkbook.FullName)

End Sub


Sub CentreSurPlusieursColonnes()
' Macro enregistrée le 17/03/99 par ADM
With Selection

 

.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False

End With
End Sub


Sub SePositionneSurRepertoireDuFichier()
' lorsqu'on a ouvert un fichier Excel, on est positionné généralement sur le répertoire par défaut d'Excel
' avec cette macro, on se positionne sur le lecteur du fichier et sur son répertoire !
''--------------------------------------------------------
' se positionne sur le dossier du fichier courant
' si FlagMessage =1 , pas de message pour ne pas arrêter
' le déroulement de la macro appelante
'--------------------------------------------------------
NomAbsolu = ActiveWorkbook.FullName
If Mid$(NomAbsolu, 2, 1) = ":" Then

 

For i = Len(NomAbsolu) To 1 Step -1
If Mid$(NomAbsolu, i, 1) = "\" Then
RepAbsolu = Left(NomAbsolu, i)
i = 1
End If

Next i
ChDrive (Left(RepAbsolu, 2))
ChDir (RepAbsolu)
If FlagMessage = 0 Then Affichage = MsgBox("répertoire selectionné :" & Chr$(13) & RepAbsolu, vbInformation, "Changement de répertoire")

Else 'cas où le fichier s'appelle juste "Classeur1"

If FlagMessage = 0 Then Affichage = MsgBox("classeur non enregistré", vbExclamation, "Changement de répertoire")

End If
FlagMessage = 0
End Sub


 

 

Ajouter le nom complet du classeur dans le pied de page (pour édition) de la feuille

Sub nomclasseurdanspiedpage()

' Macro enregistrée le 19/07/99 par GVdK CUY

For Each F In Worksheets

F.PageSetup.CenterFooter = ActiveWorkbook.FullName

Next F

End Sub

 


 

Masque les lignes vides d'une sélection

Sub masquelignesvides()

' Macro enregistrée le 19/07/99 par GVdK CUY

For Each c In Selection

If Application.CountA(c.EntireRow) = 0 Then Rows(c.Row).RowHeight = 0

Next c

 

End Sub


 

Selectionne une plage de cellule à partir d'une cellule sélectionnée

Sub selectionplage()

' Macro enregistrée le 19/07/99 par GVdK CUY

Set Maplage = ActiveCell.CurrentRegion

Nlignes = InputBox("Nombre de lignes", , 1)

Ncolonnes = InputBox("Nombre de colonnes", , 1)

Maplage.Resize(Nlignes, Ncolonnes).Select

 

End Sub

 


 


 

 

 

 

 

 

Des liens ne fonctionnent plus ?
Avez-vous des suggestions ?


Envoyez-moi un E-Mail (cuy.w(at)skynet.be)

Attention (at) signifie @

copyleft

 

 

 

 

Merci de votre visite à partir de :

Vous êtes sur :
https://cuy.be/cours/excel/trucmacro.htm

partager sur FaceBook...           consulter sur FaceBook...

 

copyleft
Des liens ne fonctionnent plus ?
Avez-vous des suggestions ?
des commentaires, des corrections, un encouragement... ?
Pour info : Non, il n'y a pas de version papier ou DOC, PDF, etc. de ces notes.


Envoyez-moi un E-Mail (cuy(point)w(at)skynet(point)be)

Attention (at) signifie @ et (point) signifie .

Accueil CUY = See you why?

Compteur gratuitEasyCounter     BelStat Monitored by BelStat - Your Site Counts
La 1 000 000e page a été visitée le 21 mai 2010.
La 2 000 000e page a été visitée ce 18 mars 2012, vers midi.
La 3 000 000e page a été visitée ce 7 janvier 2014 entre 18 h et 18 h 45,
La 4 000 000e page a été visitée ce 5 juin 2015 entre 15 h 49 et 15 h 52,
La 5 000 000e page a été visitée ce 29 aout 2017 après 23 h 30,
Et la 6 000 000e page visitée, trop tôt pour y penser ?
 
et, d'après BelStat, CUY est visité surtout en semaine, peu le weekend...
moins et irrégulièrement pendant les vacances :

visites sur 3 mois, de la mi octobre 2013 à la mi janvier 2014.
 
La 3 333 333e page visitée a eu lieu ce mardi 10 juin 2014, en début d'après midi...
La 3 666 666e page visitée a eu lieu ce dimanche 28 decembre 2014, vers 16 h...
Un tiers de million de pages visitées en 154 jours cela fait une moyenne de 2165 pages visitées par jour...
Deux tiers de million de pages visitées en 355 jours soit une moyenne de 1878 pages visitées par jour...
et seulement 1195 pages visitées quotidiennement pendant les vacances estivales
de la mi juin à la mi septembre 2014

Vous voulez lire quelques messages reçus ?
quelques encouragements ?
Cliquez ici


Fin septembre 2009, installation de ce compteur
qui ne compte chaque nouvel ordinateur visiteur qu'une seule fois
free counter
 
m-à-j du 22/11/2021 :

Depuis cette fin septembre 2009, parmi les 210 pays (sur 274 drapeaux connus) qui nous ont visité,
voici les 100 pays qui nous visitent le plus, 
Nos petits visiteurs, classés par date de visite, où un seul ordi nous a visité, sont :
199. Turkmenistan (TM May 10, 2017) ; 200. Lesotho (LS March 1, 2017) ;
201. Turks and Caicos Island (TC January 18, 2016
202. Cook Islands (CK September 19, 2015)  203. Faroe Islands (FO January 27, 2015
204. Virgin Islands American (VI November 12, 2014) ;
205. Belize (BZ September 29, 2014) ;206. Eswatini - Swaziland (SZ July 21, 2014) ;
207. Grenada (GD April 3, 2014) ; 208. Timor-Leste (TI March 29, 2014) ;
209. American Samoa (AS December 26, 2012) ; 210. Guyana (GY November 5, 2010).