MACROS EN VRAC

Avec le temps j'ai accumulé un bon nombre de codes VBA que je stock sur mon PC ou sur des clés USB. Donc j'ai décidé de les mettre sur cette page où je les retrouverai plus facilement, et le petit plus vous en faire profiter.

En fait il s'agit de MACROS diverses et variées mais qui peuvent vous faciliter la "vie".

En voici la liste :
=> Compter les valeurs numériques identiques dans une plage de cellule que vous avez choisie dans la boite de dialogue.
=> Compter le nombre de cellules vides dans une plage de cellule sélectionnée.
=> Déplacer la cellule active suivant votre choix dans boite de dialogue.
=> Sélectionner une cellule suivant votre choix dans la boite de dialogue et scroll l'écran.
=> Afficher tous les commentaires.
=> Masquer tous les commentaires.
=> Compter le nombre de foix où une valeur est présente dans une feuille.
=> Ajuster la colonne sélectionnée.
=> Supprimer les lignes vides d'un tableau si la colonne A est vide.
=> Supprimer les lignes vides.
=> Supprimer des caractères spéciaux dans une sélection de cellules.
=> Rechercher une valeur, sélectionne la ligne de la valeur trouvée et supprimer cette ligne avec un message de confirmation.
=> Compare les valeurs de deux colonnes et extrait les données manquantes dans une autre colonne.
=> Rechercher une valeur et sélectionne la ligne de la valeur trouvée.
=> Repérer les doublons dans une plage de cellules
=> Mettre en majuscule la première lettre de la phrase de la sélection.
=> Mettre en majuscule toute la phrase de la sélection. 
=> Mettre en minuscule toute la phrase de la sélection.
=> Inscrire une mention dans la cellule suivante la note attribuée.
=> Sélectionner une plage de cellule via la boite de dialogue puis colore en gris les cellules de valeur supérieures à 30.
=> Écrire les jours de la semaine (Sélection d'une cellule).
=> Créer un tableau Année - Trimestre (Sélection d'une cellule). 
=> Créer un tableau Jour _ Semaine  (Sélection d'une cellule).
=> Donner le nom de tous les fichier ouverts.
=> Donner le chemin complet du fichier ouvert.
=> Inscrire automatiquement la date de modification du classeur à sa fermeture.
=> Nommer la feuille active avec la valeur de la cellule A1. 
=> Nommer toutes les feuilles actives avec la valeur de la cellule A1 de chaque feuille.
=> Insérer une feuille nommée "LISTE des FEUILLES" et crée le sommaire du classeur.
=> Insérer une feuille et liste les feuilles sous forme de liens hypertextes.
=> Insérer des feuilles et les nomme en fonction du liste prédéfin.
=> Trier toutes les feuilles du fichier par ordre alphabétique.
=> Sélectionner une cellule via une boite de dialogue et insère un commentaire.
=> Masquer tous les onglets du classeur.
=> Afficher tous les onglets du classeur. 
=> Masquer les en-têtes de ligne et colonne.
=> Afficher les en-têtes de ligne et colonne. 
=> Insérer 12 feuilles et les nommes suivant les 12 mois de l'année.
=> Supprimer toutes les feuilles vides du classeur.
=> Protéger toutes les feuilles du classeur.
=> Enlever la protection de toutes les feuilles du classeur.
=> Interdire l'impression du classeur.
=> Toujours ouvrir le classeur sur une feuille définie.
=> Compter le nombre de fois où une valeur est présente dans la feuille.
=> Remplacer la formule par sa valeur dans une cellule.
=> Masquer le quadrillage dans une feuille.
=> Afficher le quadrillage dans une feuille.
=> Lister tous les fichiers d'un dossier dans la feuille active à partir de la cellule A1.
=> Ajouter (ou insère) le nombre de lignes définies dans l'imputbox à partir de la cellule sélectionnée. 

Pour les non initiés, il faut dans un premier temps paramétrer Excel pour avoir l'accès à l'onglet développeur et activer les macros :
Consulter cette page sur ce même blog : CREER SON FORMULAIRE


Maintenant nous allons cliquez sur l'onglet "Développeur" pour accéder à la programmation via Visual Basic.

Nous accédons à l'environnement Microsoft Visual Basic :

A ce stade sélectionnez l'onglet "Insertion" et cliquez sur Module

Sélectionnez le Module1 et positionnez votre curseur dans la partie de droite.

Maintenant vous pouvez insérer les différentes macros qui vont être mises à disposition sur cette page. Amusez vous bien !!!


Compte les valeurs numériques identiques dans une plage de cellule que vous avez choisie dans la boite de dialogue : 
Sub Valeurs_Numériques_identique()

Spinner = 0

Set plageCherche = Application.InputBox(Prompt:="Sélectionner la plage de recherche",      Type:=8) 

ValCherchée = Application.InputBox(Prompt:="Quelle valeur cherchez-vous?", Type:=1

For Each Item In plageCherche 

If Item.Value = ValCherchée Then Spinner = Spinner + 1

Next Item 

MsgBox "Il y a " & CStr(Spinner) & " valeurs identiques"

End Sub

Compte le nombre de cellules vides dans une plage de cellule sélectionnée :  
Sub Nombre_Cellules_vides()  
numBlanks = 0
For Each c In selection
If c.Value = "" Then
numBlanks = numBlanks + 1
End if
Next c
MsgBox "Il y a " & numBlanks & " cellules vides dans cette plage."
End Sub



Déplacer la cellule active suivant votre choix dans boite de dialogue  :  
Sub DéplaceCellActive()
    Dim LigVar, ColVar
    Dim LIG As String
    Dim COL As String
  
LIG = InputBox("Mentionnez le nombre de ligne : " & Chr(10) & _
"a) vers le bas  (chiffre positif) (ex. =>  1)" & Chr(10) & _
"b) vers le haut (chiffre négatif) (ex. => -1) : ")
    LigVar = LIG
  
COL = InputBox("Mentionnez les nombre de colonne : " & Chr(10) & _
"a) à droite (chiffre positif) (ex. =>  1) " & Chr(10) & _
"b) à gauche (chiffre négatif) (ex. => -1) : ")
ColVar = COL
    Selection.Offset(LigVar, ColVar).Select
End Sub



Sélectionne une cellule suivant votre choix dans la boite de dialogue et scroll l'écran
Sub SelectCell()
Dim M
M = InputBox("Mentionnez la cellule : ")
    Application.GoTo Reference:=ActiveSheet.Range(M), Scroll:=True
End Sub


Affiche tous les commentaires :
Sub AFFICHE_Tous_Les_Commentaires()
Dim WS As Worksheet, MyCmt As Comment
If MsgBox("Etes-vous certain de vouloir afficher les commentaires ?", vbYesNo, "Demande de confirmation") = vbYes Then
For Each WS In Worksheets
For Each MyCmt In WS.Comments
    MyCmt.Visible = False  ' Masque le commentaire
    MyCmt.Visible = True   ' Affiche le commentaire
Next MyCmt
Next WS
End If
End Sub

Masque tous les commentaires :
Sub MASQUE_Tous_Les_Commentaires()
Dim WS As Worksheet, MyCmt As Comment
If MsgBox("Etes-vous certain de vouloir masquer les commentaires ?", vbYesNo, "Demande de confirmation") = vbYes Then
For Each WS In Worksheets
For Each MyCmt In WS.Comments
    MyCmt.Visible = True  ' Affiche le commentaire
    MyCmt.Visible = False  ' Masque le commentaire
Next MyCmt
Next WS
End if
End Sub



Compte le nombre de fois où une valeur est présente dans une feuille :  
Sub Compter_une_valeur()
nombre = InputBox("Inscrivez la valeur à compter", "nombre", 0)
nbre = WorksheetFunction.CountIf(Range("A:IV"), nombre)
MsgBox ("La valeur " & nombre & " est présente " & nbre & " fois dans cette feuille!!")
Range("A1").Activate
End Sub) 



Ajuste la colonne sélectionnée :  
Sub Ajuste_Colonne()
Selection.Columns.AutoFit
End Sub

Supprime les lignes vides d'un tableau si la colonne A est vide : Sub SupprimeLigneSiColonneVide()
    derniereLigne = ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    For r = derniereLigne To 1 Step -1
        If IsEmpty(Range("A" & r)) Then Rows(r).Delete
    Next r
End Sub

Version plus rapide :
Sub SupprimeLigneSiColonneVide()
With Range("A1", Range("A65000").End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Supprime les lignes vides :
 Sub Supprime_lignes_Vides()
    derniereLigne = ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    For r = derniereLigne To 1 Step -1
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
End Sub

Supprimer des caractères spéciaux dans une sélection de cellules :

Sub Supprime_caracteres_Speciaux()
Dim c As Range
  For Each c In Selection
    If Replace(c, "_", "") = "" Then c = ""
  Next
End Sub


Recherche une valeur, sélectionne la ligne de la valeur trouvée et supprime cette ligne avec message de confirmation  :
Sub Supprime_Ligne_suivant_Valeur_recherchée()
    Dim Var
    Dim NumLg
    On Error Resume Next
    Var = InputBox("Taper la valeur recherchée : ", "VALEUR RECHERCHEE")
    Cells.Find(What:=(Var), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
    With Application.ActiveCell
        NumLg = .Row
    End With
    ActiveCell.EntireRow.Select
    Style = vbYesNo + vbDefaultButton1
    Msg = "Suppression de la ligne N°: " & NumLg
    Title = "Attention suppression de la ligne."
    Réponse = MsgBox(Msg, Style, Title)
    If Réponse = vbYes Then
        Selection.Delete Shift:=xlUp
    Else
        Exit Sub
    End If
End Sub
 
Compare les valeurs de 2 colonnes et extrait les données manquantes dans une autre colonne : 
Ici compare la colonne A et B et résultat dans la colonne D 
Sub test()

Dim Plage As Range, c As Range, Ligne As Long
Set Plage = Range("A1", Range("A65536").End(xlUp))

Ligne = 1
For Each c In Plage
If WorksheetFunction.CountIf(Range("B:B"), c.Value) = 0 Then 
Range("D" & Ligne).Value = c.Value 
Ligne = Ligne + 1
End If
Next c 
End Sub

Recherche une valeur et sélectionne la ligne de la valeur trouvée :
Sub Rechercher_Valeur()
    Dim Var
    Dim NumLg
    On Error Resume Next
    Var = InputBox(Prompt:="Taper la valeur recherchée. ")
    Cells.Find(What:=(Var), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
    With Application.ActiveCell
        NumLg = .Row
    End With
    ActiveCell.EntireRow.Select
    MsgBox "Valeur trouvée en ligne N°: " & NumLg
 End Sub

Repérer les doublons dans une plage de cellules : 
Les premières valeurs de la liste seront mises sur fond vert et les doublons repérés sur fond rouge.
Sub Doublons()
Dim Collec As New Collection, Cell As Range, Plage As Range
On Error Resume Next
Set Plage = Application.InputBox("Plage à examiner", Type:=8)
If IsEmpty(Plage) Then Exit Sub
For Each Cell In Plage
If Cell.Value <> "" Then
Collec.Add Cell.Value, CStr(Cell.Value)
If Err <> 0 Then
Err.Clear
Cell.Interior.ColorIndex = 3
Else
Cell.Interior.ColorIndex = 4
End If
End If
Next Cell
End Sub

Transformer du TEXTE en valeur numérique dans une plage de cellules : 

Sub TextNum()

Dim CEL As Range

Dim REF As Range

Dim M

Set REF = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)

M = REF.Address

For Each CEL In Range(M)

CEL.NumberFormat = "0"

Next CEL

End Sub

Mets en majuscule la première lettre de la phrase de la sélection  :

Sub 1ere_Lettre_majuscule()
                phrase = Selection.Value
                phrase = UCase(Left(phrase, 1)) + Right(phrase, Len(phrase) - 1)
                Selection.Value = phrase
End Sub

Mets en majuscule toute la phrase de la sélection :

Sub Minuscule_Majuscule()
                Dim MotsCellule As String
                MotsCellule = Selection.Value
                MotsCellule = UCase(MotsCellule)
                Selection.Value = MotsCellule
End Sub

Mets en minuscule toute la phrase de la sélection :
Sub MajusculeMinuscule()

                Selection = Evaluate("transpose(lower(transpose(" & Selection.Address & ")))")
End Sub


Inscrit une mention dans la cellule suivant la note mentionnée dans la boîte de dialogue :
Sub SAISIE_MENTION()
Dim Nombre As Double
'En cas d'erreur, on va à l'étiquette MauvaisType
On Error GoTo MauvaisType
Nombre = InputBox("Saisir la note obtenue : ", "Saisie MENTION")

'Ici le traitement souhaité, par exemple
Select Case Nombre
    Case Is >= 18: ActiveCell = "Mention très bien" 'Supérieur ou égal à 18
    Case Is >= 16: ActiveCell = "Mention bien" 'Supérieur ou égal à 16 etc....
    Case Is >= 14: ActiveCell = "Mention passable"
    Case Is >= 10: ActiveCell = "Pas de mention"
    Case Is >= 8: ActiveCell = "Mention pas bien"
    Case Is >= 6: ActiveCell = "Mention pas bien du tout"
    Case Else: ActiveCell = "Mention très nul"
End Select
Exit Sub 'Sortie à ne pas oublier pour ne pas traiter MauvaisType

MauvaisType:
MsgBox "Vous n'avez pas saisi de note", vbCritical
End Sub


Sélection d'une plage de cellules via la boîte de dialogue puis colore en gris les cellules supérieures à 30 :
Sub ColorCell()
Dim REF As Range
Dim Cell, M
Set REF = Application.InputBox(prompt:="Sélectionner les cellules sur la feuille", Type:=8)
  
 M = REF.Address
 For Each Cell In Range(M)
        If Cell.Value > 30 Then  'Supérieur mais peut modifier avec les valeur >= ou < ou <=
            Cell.Select
            With Selection.Interior
                .ColorIndex = 15 'GRIS
                .Pattern = xlSolid
            End With
        End If
    Next
End Sub

 Ecrit les jours de la semaine (Sélection d'une cellule)
Sub JourSemaine()
Dim semaine(1 To 7) As String
semaine(1) = "Lundi"
semaine(2) = "Mardi"
semaine(3) = "Mercredi"
semaine(4) = "Jeudi"
semaine(5) = "Vendredi"
semaine(6) = "Samedi"
semaine(7) = "Dimanche"
For i = 1 To 7
Selection.Offset(i - 1, 0).Formula = semaine(i)
Next i
End Sub

Crée un tableau Année - Trimestre  (Sélection d'une cellule) : 
Sub Tableau_Année_Trimestre()
For An = 1 To 5
Cells(1, An + 1).Value = 2000 + An
Next An
For Trimestre = 1 To 4
Cells(Trimestre + 1, 1).Value = "Trim" & Trimestre
Next Trimestre
End Sub

Crée un tableau Jour _ Semaine  (Sélection d'une cellule) :
Sub Tableau_Jour_Semaine()
Dim semaine(1 To 7) As String
For SEM = 1 To 52
Cells(1, SEM + 1).Value = 0 + SEM
Next SEM
semaine(1) = "Lundi"
semaine(2) = "Mardi"
semaine(3) = "Mercredi"
semaine(4) = "Jeudi"
semaine(5) = "Vendredi"
semaine(6) = "Samedi"
semaine(7) = "Dimanche"
For i = 1 To 7
Cells(i + 1, 1).Formula = semaine(i)
Cells(1, 1).Value = "SEMAINE/JOUR"
Next i
End Sub

Donne le nom de tous les fichier ouverts:
Sub Nom_Fichiers_ouverts()
Dim Wkb As Workbook
For Each Wkb In Workbooks
MsgBox Wkb.Name
Next Wkb
End Sub

Donne le chemin complet du fichier ouvert : 

Sub CheminFichier()
Range("A1").Value = ActiveWorkbook.FullName

End Sub 

Inscrire automatiquement la date de modification du classeur à sa fermeture : 

En utilisant l’événement BeforeClose la macro suivante inscrit automatiquement la date de la dernière modification dans la cellule A1 de la première feuille de votre classeur. 

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets(1).[A1] = "Dernière modification le " & Format(Date, "dd/mm/yyyy")
End Sub 

Nomme la feuille active avec la valeur de la cellule A1 : 
Sub Nom_Onglet()
Dim Name As String
Name = Range("A1")
Application.ScreenUpdating = False
ActiveSheet.Name = (Name)
End Sub

Nomme toutes les feuilles actives avec la valeur de la cellule A1 de chaque feuille : 
Sub Nom_Tous_Onglets() 

For i = 1 To Sheets.Count

With Sheets(i)

.Select

.Name = [A2]

End With

Next i

End Sub

 

Insère une feuille nommée "LISTE des FEUILLES" et crée le sommaire du classeur :

Sub Liste_Feuilles()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ArrFeuil = Sheets("LISTE des FEUILLES")
ArrFeuil.Cells(1, 1).Value = "Tableau des feuilles"
For i = 2 To ActiveWorkbook.Sheets.Count
ArrFeuil.Cells(i, 1).Value = Sheets(i).Name
Next i
Application.DisplayAlerts = True
Alerte = True
Application.ScreenUpdating = True
End Sub

Insère une feuille nommée " Sommaire" avec les noms des feuilles du classeur et un lien hypertexte vers chacune d'elles :

Sub Sommaire_Liste_onglet()
Application.ScreenUpdating = False
Set Nouvelle_Feuille = Sheets.Add(Before:=Sheets(1))
    On Error GoTo GesErr
DebProc:
    Nouvelle_Feuille.Name = "Sommaire"
    [A1] = "Liste des onglets du classeur"
        With Selection.Font
            .Bold = True
            .Size = 12
        End With
    For i = 2 To Sheets.Count
        Nouvelle_Feuille.Cells(i, 1).Value = Sheets(i).Name
        With Worksheets(Nouvelle_Feuille.Name)
            ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i, 2), _
                Address:="", SubAddress:=Sheets(i).Name & "!A1", _
                    TextToDisplay:="Lien vers " & Sheets(i).Name
        End With
    Next i
    With Rows("1:1")
        .RowHeight = 40
        .VerticalAlignment = xlCenter
    End With
    [E2].Activate
    ActiveWindow.DisplayGridlines = False
    Exit Sub
GesErr:
    Application.DisplayAlerts = False
    Sheets("Sommaire").Delete
    Application.DisplayAlerts = True
    GoTo DebProc
End Sub

Insère une feuille et liste les feuilles sous forme de liens hypertextes :

Sub LstSheetHyperlink()
Set newfeuille = ActiveWorkbook.Sheets.Add(Type:=xlWorksheet)
For i = 1 To Sheets.Count
newfeuille.Cells(i, 1).Value = Sheets(i).Name
With Worksheets(newfeuille.Name)
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:= _
Chr(39) & Sheets(i).Name & Chr(39) & "!A1" End With
Next i
End Sub

Créer des liens hypertexte pour accèder aux fichiers présents dans un dossier :

Sub CreationLienDossier()

Dim PlgCellules As Range

Dim TxtNomFichier As String

For Each PlgCellules In Range("B6:B1000")

TxtNomFichier = Dir("Mentionnez le chemin du dossier\*")

Do While TxtNomFichier <> ""

If InStr(TxtNomFichier, PlgCellules) Then

ActiveSheet.Hyperlinks.Add Anchor:=PlgCellules.Offset(0, 0), Address:="Mentionnez le chemin du dossier\" & TxtNomFichier, TextToDisplay:=TxtNomFichier

TxtNomFichier = Dir()

Else

TxtNomFichier = Dir()

End If

Loop

Next

End Sub

Insère des feuilles et les nomme en fonction du liste prédéfini :

Créez une liste de noms et sélectionnez la avant de lancer la macro

Sub FeuilViaLst()
Dim Mycell As Range, Mysheet As Worksheet, MyName$
For Each Mycell In Selection 'liste de noms
MyName = Mycell.Value
If MyName <> "" Then
On Error Resume Next
Set Mysheet = Sheets(MyName)
On Error GoTo 0
If Mysheet Is Nothing Then Sheets.Add.Name = MyName
End If
Next Mycell
End Sub

Trie toutes les feuilles du fichier par ordre alphabétique :
Sub Trier_Feuilles()

Dim X As Variant

Dim I As Variant

For Each X In ActiveWorkbook.Sheets

For I = 2 To ActiveWorkbook.Sheets.Count

If Sheets(I - 1).Name > Sheets(I).Name Then

Sheets(I - 1).Move After:=Sheets(I)

End If

Next

NextEnd Sub

Sélectionne une cellule via une boite de dialogue et insère un commentaire :
Sub InsertionComment()
Dim MyCmt As String
Dim LaCell As Range
Set LaCell = Application.InputBox("Cliquez sur une cellule", Default:=ActiveCell.Address, Type:=8)
MyCmt = InputBox("Inscrivez votre commentaire")
On Error Resume Next
With LaCell
.AddComment
With .Comment
.Visible = True
.Text Text:=MyCmt
End With
End With
End Sub

Masque tous les onglets du classeur :
Sub MasqueOnglet()
With ActiveWindow
.DisplayWorkbookTabs = Not .DisplayWorkbookTabs
End With
End Sub

Affiche tous les onglets du classeur :
Sub AfficheOnglet()
ActiveWindow.DisplayWorkbookTabs = True
End Sub

Masque les en-têtes de ligne et colonne :
Sub Masque_Entetes_de_Ligne_et_Colonne()
'masque les en-têtes de ligne et colonne
ActiveWindow.DisplayHeadings = False
End Sub

Affiche les en-têtes de ligne et colonne :
Sub Affiche_Entetes_de_Ligne_et_Colonne()
'affiche les en-têtes de ligne et colonne
ActiveWindow.DisplayHeadings = True
End Sub

Insère 52 feuilles et les nommes suivant les 52 semaines de l'année :
Sub  NomFeuilleSemaine()
    Dim i%
    For i = 1 To 52
        With Worksheets.Add(after:=Worksheets(Worksheets.Count))
            .Name = "Semaine " & i
        End With
    Next i
End Sub

Insère 12 feuilles et les nommes suivant les 12 mois de l'année :
Sub NomFeuillesMois()
For I = 1 To 12
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(30 * I, "mmmm")
Next I
End Sub

Copie un modèle et le duplique selon les 365 jours de l'année. Nomme les onglets par date  :
Option Explicit
Public Sub Creer_Onglets_JOURS()
Dim année, i, z
Dim x As Date, y As Date
    année = Val(InputBox("Quelle année ?"))
    If année = 0 Then Exit Sub
    Application.ScreenUpdating = False
    x = DateSerial(année, 1, 0)
    y = DateValue("31 décembre " & année)
    z = y - x
    For i = 1 To z
        Worksheets("Modèle").Copy After:=Sheets(i)
        ActiveSheet.Name = Format(x + i, "dd-mmm-yyyy")
        ActiveSheet.Range("A1") = Format(x + i, "dd-mmm-yyyy")
    Next i
    Worksheets("Modèle").Activate
    Cells(1, 1).Select
End Sub

Supprime toutes les feuilles sauf l'onglet "Modèle" du classeur :
Option Explicit

Public Sub SupprimerOnglets()
Dim ws As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Modèle" Then ws.Delete
    Next
    Application.DisplayAlerts = True
End Sub)

 Supprime toutes les feuilles vides du classeur :
Sub DelFeuilleVide()
Set LaCell = ActiveCell
Set MaFeuille = ActiveWorkbook.ActiveSheet
On Error Resume Next
For Each x In ActiveWorkbook.Worksheets
x.Activate
Selection.SpecialCells(xlLastCell).Select
LeTestFeuil = False
For Each y In ActiveSheet.DrawingObjects
LeTestFeuil = True
Exit For
Next
If ActiveCell.Address = "$A$1" And IsEmpty(ActiveCell) And LeTestFeuil = False Then
Application.DisplayAlerts = False
x.Delete
Application.DisplayAlerts = True
End If
Next x
MaFeuille.Activate
LaCell.Select
End Sub

Protège toutes les feuilles du classeur :
Sub Protéger()
    Dim Rep As String
    Rep = InputBox("Entrez le mot de passe", "SAISIE MOT DE PASSE")
    If Rep <> "Mot de passe" Then 'indiquer votre mot de passe
        MsgBox "Mot de passe incorrect"
        Exit Sub
    End If
    For Each WS In Worksheets
         WS.Protect Password:="Mot de passe" 'indiquer votre mot de passe
    Next WS
End Sub


Enlève la protection de toutes les feuilles du classeur :
Sub Déprotéger()
    Dim Rep As String
    Rep = InputBox("Entrez le mot de passe", "SAISIE MOT DE PASSE")
    If Rep <> "Mot de passe" Then  'indiquer votre mot de passe
        MsgBox "Mot de passe incorrect"
        Exit Sub
    End If
    For Each WS In Worksheets
        WS.Unprotect Password:="Mot de passe" 'indiquer votre mot de passe
    Next WS
End Sub


Interdire l'impression du classeur :
Insérer le programme suivant dans ThisWorkbook dans le VBAProject  => Procédure :
* Lancer l'éditeur VBA par ALT + F11
* CTRL + R pour accéder à VBAProject à gauche
* Là double-cliquez sur ThisWorkbook
* Placez (Copier/Coller) la macro ci-dessous

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = True
MsgBox ("Vous n'avez pas l'autorisation d'imprimer ce classeur")
End Sub

Toujours ouvrir le classeur sur une feuille définie :
Insérer le programme suivant dans ThisWorkbook dans le VBAProject
Private Sub Workbook_Open()
Sheets("nom_de_la_feuille").Select 'Indiquer le nom de la feuille à ouvrir par défaut
End Sub

Compte le nombre de fois où une valeur est présente dans la feuille :

Sub Compter_une_valeur()
nombre = InputBox("Inscrivez la valeur à compter", "nombre", 0)
nbre = WorksheetFunction.CountIf(Range("A:IV"), nombre)
MsgBox ("La valeur " & nombre & " est présente " & nbre & " fois dans cette feuille !!")
Range("A1").Activate
End Sub 

Remplace la formule par sa valeur dans une cellule :
Sub Formule_Valeur()
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Application.CutCopyMode = False
End Sub

Masque le quadrillage dans une feuille :
Sub Masque_Quadrillage()
    ActiveWindow.DisplayGridlines = False
End Sub

Affiche le quadrillage dans une feuille :
Sub Affiche_Quadrillage()
    ActiveWindow.DisplayGridlines = True
End Sub

Affiche et masque le quadrillage dans une feuille :
Sub Masque_Affiche_Quadrillage()
Quadrillage = ActiveWindow.DisplayGridlines
Quadrillage = Not Quadrillage
ActiveWindow.DisplayGridlines = Quadrillage
End Sub


Liste tous les fichiers d'un dossier dans la feuille active à partir de la cellule A1 :
Sub ListingFichiers()
Dim Rep As String, Fichier As String
Dim i As Integer
Rep = InputBox("Mentionnez la cellule : ")
Fichier = Dir(Rep)
Do While Fichier <> ""
    i = i + 1
    ActiveSheet.Range("A" & i) = Fichier
    Fichier = Dir
Loop
End Sub

Ajoute (ou insère) le nombre de lignes définies dans l'imputbox à partir de la cellule sélectionnée:

Sub INSERER_LIGNE()
        x = InputBox("Donnez un nombre de lignes")
        y = ActiveCell.Row + 1
        For i = 1 To x
            ActiveSheet.Rows(y).Insert
        Next i
  End Sub

Supprime les espaces et les retours à la ligne :

Sub SUPPRIME_ESPACE_ET_RETOUR_LIGNE()
Dim c As Range
For Each c In ActiveSheet.UsedRange
c = Trim(c)
c.Replace What:=Chr(10), Replacement:=""
c.Replace What:=" ", Replacement:=""
Next c
End Sub

Supprime les espaces  d'une sélection :

 Sub SUPPRIME_ESPACE()
'Supprime les espaces
'LTrim pour supprimer les espaces ˆ gauche
'RTrim pour supprimer les espaces ˆ droite
For Each cel In Selection
        cel.Value = RTrim(cel.Value)
        cel.Value = LTrim(cel.Value)
Next cel
End Sub

 Copier une ligne X fois :



Sub COPIER_COLLER_LIGNE_X_FOIS()
Dim lignes As Integer
Dim debut As Integer
lignes = InputBox("Nombre de lignes à dupliquer ?")
For debut = 1 To lignes
With ActiveCell.EntireRow
.Offset(debut, 0).Insert Shift:=xlDown
.Copy Destination:=.Offset(debut, 0)
End With
Next debut
End Sub

Fonction pour effectuer la somme des cellules visibles :

Function SommeCellulesVisibles(Plage As Range)

Dim CEL As Range

Dim TOTAL As Double

  Application.Volatile

  T0TAL = 0

  For Each CEL In Plage

    If Not CEL.EntireRow.Hidden And Not CEL.EntireColumn.Hidden Then

      TOTAL = TOTAL + CEL.Value

    End If

  Next CEL

  SommeCellulesVisibles = TOTAL

End Function

Ex. dans une cellule =SommeCellulesVisibles(A1:A5)