Macro pour ajouter une fonction au menu contextuel :

Dans cet exemple, nous allons intégrer au menu contextuel une fonction qui permet d'imprimer les cellules sélectionnées.

Appliquer Outils/Macro/Nouvelle macro...
Comme nom de macro écriver Modifiemenucontextuel
Cliquer sur le bouton OK
Arreter l'enregistrement de la macro, en cliquant sur le carré bleu.
Appuyer sur les touches Alt + F11 pour démarrer la fenetre de Visual Basic
Dans la fenetre Projet, double cliquer sur Module 1 du VBAproject(perso.xls).
Copier/coller le texte ci dessous dans la fenetre de droite:

'Le code de l'action associée au nouvel item du menu contextuel
Sub ImprimeSelection()
Selection.PrintOut Copies:=1, Collate:=True
End Sub

'Le code pour ajouter le menu contextuel
Sub InsereMenuContextuel()
With Application.CommandBars("Cell").Controls.Add(msoControlButton)
.Caption = "Imprime la sélection"
.BeginGroup = True
.FaceId = 343
.OnAction = "ImprimeSelection"
End With
End Sub

Appeler le menu Fichier/Enregistrer perso.xls
Appeler le menu Execution/Executer Sub/Userform
Fermer la fenetre de Visual Basic

Remarque : si vous appelez plusieurs fois le menu Execution/Executer Sub/Userform, alors vous obtiendrez une multitude de nouveaux items dans le menu contextuel. Pour remedier à cela, effacer toutes les macros et copier/coller le texte suivant dans la fenetre de droite du module1 :

'Le code pour supprimer le menu contextuel
Sub SupprimeMenuContextuel()
Application.CommandBars("Cell").Reset
End Sub

Appeler le menu Fichier/Enregistrer perso.xls
Appeler le menu Execution/Executer Sub/Userform
Fermer la fenetre de Visual Basic

Macro pour ajouter des fonctions en sous menu au menu contextuel :

Dans cet exemple, nous allons intégrer au menu contextuel, un sous menu "Mise en forme" qui possèdera les fonctions "Fusionner" et "Fractionner".

Appliquer Outils/Macro/Nouvelle macro...
Comme nom de macro écriver Modifiemenucontextuel
Cliquer sur le bouton OK
Arreter l'enregistrement de la macro, en cliquant sur le carré bleu.
Appuyer sur les touches Alt + F11 pour démarrer la fenetre de Visual Basic
Dans la fenetre Projet, double cliquer sur Module 1 du VBAproject(perso.xls).
Copier/coller le texte ci dessous dans la fenetre de droite:

'Le code pour ajouter le menu contextuel
Sub InsereMenuContextuel()
Dim mCtrl As CommandBarPopup
Set mCtrl = Application.CommandBars("Cell"). _
Controls.Add(msoControlPopup, before:=1)
With mCtrl
.Caption = "Mise en forme"
.BeginGroup = False
' Sous-menu 1 (Exemple 1.1)
.Controls.Add (msoControlButton)
.Controls(1).Caption = "Fusionner"
With .Controls(1)
.OnAction = "Fusion"
.FaceId = 351
End With
' Sous-menu 2 (Exemple 1.2)
.Controls.Add (msoControlButton)
.Controls(2).Caption = "Fractionner"
With .Controls(2)
.OnAction = "Fraction"
.FaceId = 352
End With
End With
End Sub

'Le code des actions ("fusionner" "fractionner") associées au sous menu Divers
Sub Fusion()
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
End Sub

Sub Fraction()
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
End Sub

Appeler le menu Fichier/Enregistrer perso.xls
Appeler le menu Execution/Executer Sub/Userform
Fermer la fenetre de Visual Basic

Macro pour activer/désactiver une fonction activable grace à une case à cocher
Créer une Nouvelle macro et donner lui un raccourci.
Appeler le menu, puis la fonction (activable grace à une case à cocher) désirée.
Arreter l'enregistrement de la macro.
Ouvrer VisulBasic (Alt + F11).
Vous obtenez un code similaire à celui ci :

Sub AfficheMasqueBarreDeFormule()
Application.DisplayFormulaBar = False
End Sub

Copier la syntaxe à gauche du signe =
Remplacer le mot False (ou True) par le mot Not
Coller la syntaxe

Sub AfficheMasqueBarreDeFormule()
Application.DisplayFormulaBar = Not Application.DisplayFormulaBar
End Sub

Essayer votre touche de raccourci : la fonction s'active et se désactive.

Macro pour créer une fonction qui somme les valeurs des cellules qui ont une couleur particulière

=SumByColor(Plage;cellule_couleur_référence)

Appliquer Outils/Macro/Nouvelle macro...
Comme nom de macro écriver Modifiemenucontextuel
Cliquer sur le bouton OK
Arreter l'enregistrement de la macro, en cliquant sur le carré bleu.
Appuyer sur les touches Alt + F11 pour démarrer la fenetre de Visual Basic
Dans la fenetre Projet, double cliquer sur Module 1 du VBAproject(perso.xls).
Copier/coller le texte ci dessous dans la fenetre de droite:

Function SumByColor(PlageEntree As Range, CouleurPlage As Range) As Double
Dim Cell As Range, TempSum As Double, ColorIndex As Integer
ColorIndex = CouleurPlage.Cells(1, 1).Interior.ColorIndex
TempSum = 0
On Error Resume Next
For Each Cell In PlageEntree.Cells
If Cell.Formula < > "" Then
If Cell.Interior.ColorIndex = ColorIndex Then TempSum = TempSum + _
Cell.Value
End If
Next Cell
On Error GoTo 0
Set Cell = Nothing
SumByColor = TempSum
End Function

Appeler le menu Fichier/Enregistrer perso.xls
Appeler le menu Execution/Executer Sub/Userform
Fermer la fenetre de Visual Basic

Macro qui réalise un compteur qui s'incrémente à chaque ouverture du classeur

Selectionner une cellule, appeler le menu Insertion / Nom / Définir
Ecriver compteur
Cliquer sur le bouton "Ajouter"
Cliquer sur le bouton OK

Appliquer Outils/Macro/Nouvelle macro...
Comme nom de macro écriver Modifiemenucontextuel
Cliquer sur le bouton OK
Arreter l'enregistrement de la macro, en cliquant sur le carré bleu.
Appuyer sur les touches Alt + F11 pour démarrer la fenetre de Visual Basic
Dans la fenetre Projet, double cliquer sur Module 1 du VBAproject(perso.xls).
Copier/coller le texte ci dessous dans la fenetre de droite:

Sub auto_open()
Range("compteur") = Range("compteur") + 1
End Sub

Private Sub Workbook_Open()
Range("compteur") = Range("compteur") + 1
End Sub

Appeler le menu Fichier/Enregistrer perso.xls
Appeler le menu Execution/Executer Sub/Userform
Fermer la fenetre de Visual Basic

Avant de fermer le classeur, enregistrer le.

Macro qui efface la ligne selon la valeur se trouvant dans la colonne A

Dans cet exemple, dès que "toto" apparait dans la colonne A, toute la ligne est supprimée.

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).ClearContents
Next
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Macro qui renomme les feuilles d'un classeur de Janvier à Décembre ou de Lundi à Dimanche ou de 01 à 12

Vous ouvrez un classeur, vous cliquez droit sur l'onglet d'une feuille, le menu contectuel apparait, vous sélectionnez l'incrémentation désirée, si vous voulez renommer les feuilles existantes, si il faut créer de nouvelle feuille si nécessaire,.... Personnellement après avoir ouvert un nouveau classeur, je sélectionne mon incrémentation, l'option 2 puis l'option 3.

'B. Marchand & F. Sigonneau mpfe
Option Explicit
Public Const Entrée As String = "Copie incrémentée de feuille(s)"
Dim Jours, Mois, MoisNum, tabListes

Sub Démarre()
Dim Ctrl As CommandBarControl, Liste, S$, x%

Set Ctrl = Application.CommandBars("Ply").Controls. _
Add(Type:=msoControlPopup, before:=1, temporary:=True)
Ctrl.Caption = Entrée

FillListes

For x = LBound(tabListes) To UBound(tabListes)
Liste = tabListes(x)
S = Liste(1) & ", " & Liste(2) & "..."
With Ctrl.Controls.Add(msoControlButton)
.Caption = S
.OnAction = "'IncrémentationFeuille " & x & "'"
End With
Next x

With Application.CommandBars("Ply").Controls(2)
.BeginGroup = True
End With
End Sub

Sub Désinstalle()
On Error Resume Next
Application.CommandBars("Ply").Controls(Entrée).Delete
End Sub

Sub IncrémentationFeuille(Param As Byte)
Dim NouvelleFeuille As String
Dim N%, M%, Liste
Dim Msg As String, retour As String, sht As Worksheet

Msg = "Pour :" & vbLf & vbLf & _
"- Ajouter une feuille avec le nom de l'entrée suivante " _
& "dans la liste : tapez 1" _
& vbLf & vbLf & _
"- Renommer les feuilles existantes avec les noms de la " _
& "liste : tapez 2" _
& vbLf & vbLf & _
"- Compléter le classeur avec autant de feuilles que " _
& "d'entrées dans la liste : tapez 3"

retour = InputBox(Msg, "Copie incrémentée de feuille(s)")
If retour = "" Then Exit Sub

FillListes
Liste = tabListes(Param)
Application.ScreenUpdating = False

Select Case Val(retour)
Case 1
If Not ListeExistante(Liste) Then GoTo Fin3
On Error GoTo Fin1
For N = 1 To UBound(Liste)
If ActiveSheet.Name = Liste(N) Then
Set sht = ActiveSheet
NouvelleFeuille = Liste(N + 1)
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = NouvelleFeuille
Exit For
End If
Next N
Case 2
M = 0
For N = 1 To Worksheets.Count
If Worksheets(N).Visible = xlSheetVisible Then
Worksheets(N).Name = "Tmp" & N - M
Worksheets(N).Name = Liste(N - M)
Else
M = M + 1
End If
If N - M = SheetsVisible And N < UBound(Liste) Then GoTo Fin2
Next N
Case 3
If Not ListeExistante(Liste) Then GoTo Fin3
For N = SheetsVisible + 1 To UBound(Liste)
NouvelleFeuille = Liste(N)
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = NouvelleFeuille
Next N
End Select
Exit Sub
Fin1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
sht.Activate
MsgBox "Une feuille porte déjà le même nom" & vbLf & _
"que l'entrée suivante dans la liste...", , Entrée
End
Fin2:
MsgBox "Ne peut tout renommer : il y a des feuilles cachées" & vbLf & _
"et/ou moins de feuilles que d'entrées dans la liste...", , Entrée
Exit Sub
Fin3:
MsgBox "La liste choisie ne correspond pas" & vbLf & _
"aux noms des feuilles existantes...", , Entrée
End Sub

Function SheetsVisible() As Long
Dim i&, V&
For i = 1 To Worksheets.Count
If Worksheets(i).Visible = xlSheetVisible Then V = V + 1
Next i
SheetsVisible = V
End Function

Function ListeExistante(Liste) As Boolean
Dim N&, M&

For N = 1 To Worksheets.Count
For M = 1 To UBound(Liste)
If Worksheets(N).Name = Liste(M) Then
ListeExistante = True
Exit Function
End If
Next M
Next N
End Function

Sub FillListes()
Jours = Array("", "Lundi", "Mardi", "Mercredi", "Jeudi", _
"Vendredi", "Samedi", "Dimanche")
Mois = Array("", "Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
"Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
MoisNum = Array("", "01", "02", "03", "04", "05", "06", _
"07", "08", "09", "10", "11", "12")
tabListes = Array(Jours, Mois, MoisNum)
End Sub