
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
|