📊 300 Astuces VBA Excel

' ============================================================


' ============================================================
' ============================================================

1. Créer un nouveau classeur

Sub Macro001_NouveauClasseur()
    Workbooks.Add
End Sub

2. Ouvrir un classeur

Sub Macro002_OuvrirClasseur()
    Dim Chemin As String
    Chemin = Application.GetOpenFilename("Fichiers Excel (*.xlsx), *.xlsx")
    If Chemin <> "False" Then Workbooks.Open Chemin
End Sub

3. Sauvegarder le classeur actif

Sub Macro003_Sauvegarder()
    ActiveWorkbook.Save
End Sub

4. Sauvegarder sous un nouveau nom

Sub Macro004_SauvegarderSous()
    Dim Nom As String
    Nom = Application.GetSaveAsFilename("MonFichier", "Fichiers Excel (*.xlsx), *.xlsx")
    If Nom <> "False" Then ActiveWorkbook.SaveAs Nom
End Sub

5. Fermer le classeur actif

Sub Macro005_FermerClasseur()
    ActiveWorkbook.Close SaveChanges:=True
End Sub

6. Fermer tous les classeurs

Sub Macro006_FermerTous()
    Dim wb As Workbook
    For Each wb In Workbooks
        wb.Close SaveChanges:=True
    Next wb
End Sub

7. Ajouter une nouvelle feuille

Sub Macro007_AjouterFeuille()
    Sheets.Add After:=Sheets(Sheets.Count)
End Sub

8. Supprimer la feuille active

Sub Macro008_SupprimerFeuille()
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

9. Renommer la feuille active

Sub Macro009_RenommerFeuille()
    Dim Nom As String
    Nom = InputBox("Nouveau nom pour la feuille :", "Renommer")
    If Nom <> "" Then ActiveSheet.Name = Nom
End Sub

10. Copier la feuille active à la fin

Sub Macro010_CopierFeuille()
    ActiveSheet.Copy After:=Sheets(Sheets.Count)
End Sub

11. Déplacer la feuille au début

Sub Macro011_DeplacerFeuille()
    ActiveSheet.Move Before:=Sheets(1)
End Sub

12. Protéger la feuille active

Sub Macro012_ProtegerFeuille()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe :", "Protection")
    ActiveSheet.Protect Password:=Mdp
End Sub

13. Déprotéger la feuille active

Sub Macro013_DeprotegerFeuille()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe :", "Déprotection")
    ActiveSheet.Unprotect Password:=Mdp
End Sub

14. Masquer la feuille active

Sub Macro014_MasquerFeuille()
    ActiveSheet.Visible = xlSheetHidden
End Sub

15. Afficher toutes les feuilles masquées

Sub Macro015_AfficherToutesFeuilles()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        sh.Visible = xlSheetVisible
    Next sh
End Sub

16. Lister toutes les feuilles dans la première colonne

Sub Macro016_ListerFeuilles()
    Dim i As Integer
    For i = 1 To Sheets.Count
        Cells(i, 1).Value = Sheets(i).Name
    Next i
End Sub

17. Aller à la dernière feuille

Sub Macro017_DerniereFeuille()
    Sheets(Sheets.Count).Activate
End Sub

18. Aller à la première feuille

Sub Macro018_PremiereFeuille()
    Sheets(1).Activate
End Sub

19. Trier les feuilles par ordre alphabétique

Sub Macro019_TrierFeuilles()
    Dim i As Integer, j As Integer
    For i = 1 To Sheets.Count - 1
        For j = 1 To Sheets.Count - 1
            If Sheets(j).Name > Sheets(j + 1).Name Then
                Sheets(j).Move After:=Sheets(j + 1)
            End If
        Next j
    Next i
End Sub

20. Changer la couleur d'onglet de la feuille active

Sub Macro020_CouleurOnglet()
    ActiveSheet.Tab.Color = RGB(255, 0, 0) ' Rouge
End Sub

21. Supprimer toutes les feuilles sauf la première

Sub Macro021_SupprimerFeuilles()
    Application.DisplayAlerts = False
    Dim i As Integer
    For i = Sheets.Count To 2 Step -1
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
End Sub

22. Créer 12 feuilles nommées par les mois

Sub Macro022_FeuillesMois()
    Dim Mois(1 To 12) As String
    Mois(1) = "Janvier" : Mois(2) = "Fevrier" : Mois(3) = "Mars"
    Mois(4) = "Avril" : Mois(5) = "Mai" : Mois(6) = "Juin"
    Mois(7) = "Juillet" : Mois(8) = "Aout" : Mois(9) = "Septembre"
    Mois(10) = "Octobre" : Mois(11) = "Novembre" : Mois(12) = "Decembre"
    Application.DisplayAlerts = False
    Dim i As Integer
    For i = Sheets.Count To 1 Step -1
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    For i = 1 To 12
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Mois(i)
    Next i
End Sub

23. Copier toutes les feuilles dans un nouveau classeur

Sub Macro023_CopierDansNouveauClasseur()
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Sheets
        sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    Next sh
End Sub

24. Importer une feuille depuis un autre classeur

Sub Macro024_ImporterFeuille()
    Dim Chemin As String
    Chemin = Application.GetOpenFilename()
    If Chemin <> "False" Then
        Dim wbSource As Workbook
        Set wbSource = Workbooks.Open(Chemin)
        wbSource.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        wbSource.Close SaveChanges:=False
    End If
End Sub

25. Afficher le nombre de feuilles

Sub Macro025_NombreFeuilles()
    MsgBox "Ce classeur contient " & Sheets.Count & " feuille(s).", vbInformation
End Sub

26. Naviguer vers une feuille par InputBox

Sub Macro026_NaviguerVers()
    Dim Nom As String
    Nom = InputBox("Nom de la feuille :")
    On Error Resume Next
    Sheets(Nom).Activate
    If Err.Number <> 0 Then MsgBox "Feuille introuvable !", vbExclamation
    On Error GoTo 0
End Sub

27. Enregistrer chaque feuille en fichier CSV separe

Sub Macro027_ExporterCSV()
    Dim sh As Worksheet
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\"
    For Each sh In ActiveWorkbook.Sheets
        sh.Copy
        ActiveWorkbook.SaveAs Filename:=Chemin & sh.Name & ".csv", FileFormat:=xlCSV
        ActiveWorkbook.Close SaveChanges:=False
    Next sh
End Sub

28. Mettre en surbrillance la feuille active (onglet jaune)

Sub Macro028_SurbrillanceFeuille()
    Dim sh As Worksheet
    For Each sh In Sheets
        sh.Tab.ColorIndex = xlColorIndexNone
    Next sh
    ActiveSheet.Tab.Color = RGB(255, 255, 0)
End Sub

29. Verrouiller la structure du classeur

Sub Macro029_VerrouillerClasseur()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe pour verrouiller :")
    ActiveWorkbook.Protect Password:=Mdp, Structure:=True
End Sub

30. Deverrouiller la structure du classeur

Sub Macro030_DeverrouillerClasseur()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe :")
    ActiveWorkbook.Unprotect Password:=Mdp
End Sub

31. Afficher le chemin complet du classeur

Sub Macro031_CheminClasseur()
    MsgBox "Chemin : " & ActiveWorkbook.FullName, vbInformation
End Sub

32. Dupliquer la feuille active N fois

Sub Macro032_DupliquerN()
    Dim N As Integer
    N = InputBox("Combien de copies ?")
    Dim i As Integer
    For i = 1 To N
        ActiveSheet.Copy After:=Sheets(Sheets.Count)
    Next i
End Sub

33. Remettre a zero toutes les cellules de la feuille

Sub Macro033_ReinitFeuille()
    If MsgBox("Effacer toute la feuille ?", vbYesNo) = vbYes Then
        Cells.ClearContents
    End If
End Sub

34. Creer une feuille de sommaire avec liens hypertextes

Sub Macro034_Sommaire()
    Dim shSommaire As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Sommaire").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set shSommaire = Sheets.Add(Before:=Sheets(1))
    shSommaire.Name = "Sommaire"
    shSommaire.Cells(1, 1).Value = "SOMMAIRE"
    Dim i As Integer
    For i = 2 To Sheets.Count
        shSommaire.Cells(i, 1).Hyperlinks.Add _
            Anchor:=shSommaire.Cells(i, 1), _
            Address:="", _
            SubAddress:="'" & Sheets(i).Name & "'!A1", _
            TextToDisplay:=Sheets(i).Name
    Next i
End Sub

35. Comparer deux feuilles et surligner les differences

Sub Macro035_ComparerFeuilles()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    Dim r As Integer, c As Integer
    For r = 1 To 100
        For c = 1 To 20
            If sh1.Cells(r, c).Value <> sh2.Cells(r, c).Value Then
                sh1.Cells(r, c).Interior.Color = RGB(255, 200, 200)
                sh2.Cells(r, c).Interior.Color = RGB(200, 200, 255)
            End If
        Next c
    Next r
End Sub

36. Exporter la feuille active en PDF

Sub Macro036_ExporterPDF()
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin
    MsgBox "PDF exporte : " & Chemin, vbInformation
End Sub

37. Figer les volets a la cellule B2

Sub Macro037_FigerVolets()
    ActiveWindow.FreezePanes = False
    Range("B2").Select
    ActiveWindow.FreezePanes = True
End Sub

38. Degeler les volets

Sub Macro038_DegelVolets()
    ActiveWindow.FreezePanes = False
End Sub

39. Afficher/Masquer les en-tetes de ligne et colonne

Sub Macro039_BasculeEntetes()
    ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings
End Sub

40. Afficher/Masquer le quadrillage

Sub Macro040_BasculeQuadrillage()
    ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines
End Sub




' ============================================================
' ============================================================

41. Selectionner toutes les cellules utilisees

Sub Macro041_SelectionnerUsedRange()
    ActiveSheet.UsedRange.Select
End Sub

42. Aller a la derniere cellule utilisee

Sub Macro042_DerniereCellule()
    Dim Derniere As Range
    Set Derniere = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
    Derniere.Select
    MsgBox "Derniere cellule : " & Derniere.Address, vbInformation
End Sub

43. Trouver la derniere ligne avec donnees

Sub Macro043_DerniereLigne()
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
    MsgBox "Derniere ligne : " & DerLigne, vbInformation
End Sub

44. Trouver la derniere colonne avec donnees

Sub Macro044_DerniereColonne()
    Dim DerCol As Long
    DerCol = Cells(1, Columns.Count).End(xlToLeft).Column
    MsgBox "Derniere colonne : " & DerCol, vbInformation
End Sub

45. Effacer le contenu d'une plage

Sub Macro045_EffacerContenu()
    Range("A1:Z100").ClearContents
End Sub

46. Effacer la mise en forme d'une plage

Sub Macro046_EffacerMiseEnForme()
    Range("A1:Z100").ClearFormats
End Sub

47. Effacer tout (contenu + format)

Sub Macro047_EffacerTout()
    Range("A1:Z100").Clear
End Sub

48. Copier/Coller une plage

Sub Macro048_CopierColler()
    Range("A1:D10").Copy Destination:=Range("F1")
End Sub

49. Couper/Coller une plage

Sub Macro049_CouperColler()
    Range("A1:D10").Cut Destination:=Range("F1")
End Sub

50. Inserer une ligne au-dessus de la selection

Sub Macro050_InsererLigne()
    Selection.EntireRow.Insert
End Sub

51. Inserer une colonne a gauche de la selection

Sub Macro051_InsererColonne()
    Selection.EntireColumn.Insert
End Sub

52. Supprimer les lignes vides

Sub Macro052_SupprimerLignesVides()
    Dim i As Long
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If WorksheetFunction.CountA(Rows(i)) = 0 Then
            Rows(i).Delete
        End If
    Next i
End Sub

53. Supprimer les doublons dans la colonne A

Sub Macro053_SupprimerDoublons()
    ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

54. Remplir les cellules vides avec la valeur au-dessus

Sub Macro054_RemplirVideAvec()
    Dim plage As Range
    Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    plage.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    plage.Value = plage.Value
End Sub

55. Inverser l'ordre des lignes

Sub Macro055_InverserLignes()
    Dim debut As Long, fin As Long
    Dim temp As Variant
    debut = 1
    fin = Cells(Rows.Count, 1).End(xlUp).Row
    Dim i As Long, j As Long
    For i = debut To (debut + fin) \ 2
        j = fin - i + debut
        If i <> j Then
            temp = Rows(i).Value
            Rows(i).Value = Rows(j).Value
            Rows(j).Value = temp
        End If
    Next i
End Sub

56. Mettre en majuscule tout le texte de la selection

Sub Macro056_Majuscule()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = UCase(c.Value)
    Next c
End Sub

57. Mettre en minuscule tout le texte de la selection

Sub Macro057_Minuscule()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = LCase(c.Value)
    Next c
End Sub

58. Mettre en casse de titre (1ere lettre majuscule)

Sub Macro058_CasseTitre()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = WorksheetFunction.Proper(c.Value)
    Next c
End Sub

59. Supprimer les espaces inutiles

Sub Macro059_SupprimerEspaces()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = Trim(c.Value)
    Next c
End Sub

60. Remplacer les virgules par des points

Sub Macro060_VirgulesPoints()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = Replace(c.Value, ",", ".")
    Next c
End Sub

61. Chercher et remplacer dans la feuille

Sub Macro061_ChercherRemplacer()
    Dim Cherche As String, Remplace As String
    Cherche = InputBox("Chercher :")
    Remplace = InputBox("Remplacer par :")
    Cells.Replace What:=Cherche, Replacement:=Remplace, LookAt:=xlPart
End Sub

62. Compter les cellules non vides

Sub Macro062_CompterNonVides()
    MsgBox "Cellules non vides : " & _
        WorksheetFunction.CountA(ActiveSheet.UsedRange), vbInformation
End Sub

63. Selectionner les cellules contenant des formules

Sub Macro063_SelectFormules()
    On Error Resume Next
    Cells.SpecialCells(xlCellTypeFormulas).Select
    On Error GoTo 0
End Sub

64. Selectionner les cellules contenant des commentaires

Sub Macro064_SelectCommentaires()
    On Error Resume Next
    Cells.SpecialCells(xlCellTypeComments).Select
    On Error GoTo 0
End Sub

65. Ajouter un commentaire a la cellule active

Sub Macro065_AjouterCommentaire()
    Dim Texte As String
    Texte = InputBox("Texte du commentaire :")
    If Texte <> "" Then
        With ActiveCell
            .AddComment
            .Comment.Text Text:=Texte
        End With
    End If
End Sub

66. Supprimer tous les commentaires de la feuille

Sub Macro066_SupprimerCommentaires()
    Cells.ClearComments
End Sub

67. Verrouiller les cellules de la selection

Sub Macro067_VerrouillerCellules()
    Selection.Locked = True
End Sub

68. Deverrouiller les cellules de la selection

Sub Macro068_DeverrouillerCellules()
    Selection.Locked = False
End Sub

69. Afficher l'adresse de la cellule active

Sub Macro069_AdresseCellule()
    MsgBox "Cellule active : " & ActiveCell.Address & _
           " | Valeur : " & ActiveCell.Value, vbInformation
End Sub

70. Nommer une plage

Sub Macro070_NommerPlage()
    Dim Nom As String
    Nom = InputBox("Nom pour la plage selectionnee :")
    If Nom <> "" Then
        ActiveWorkbook.Names.Add Name:=Nom, RefersTo:=Selection
    End If
End Sub

71. Convertir les formules en valeurs

Sub Macro071_FormulesToValeurs()
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End Sub

72. Selectionner toute la colonne de la cellule active

Sub Macro072_SelectColonne()
    ActiveCell.EntireColumn.Select
End Sub

73. Selectionner toute la ligne de la cellule active

Sub Macro073_SelectLigne()
    ActiveCell.EntireRow.Select
End Sub

74. Masquer la ligne active

Sub Macro074_MasquerLigne()
    ActiveCell.EntireRow.Hidden = True
End Sub

75. Masquer la colonne active

Sub Macro075_MasquerColonne()
    ActiveCell.EntireColumn.Hidden = True
End Sub

76. Afficher toutes les lignes masquees

Sub Macro076_AfficherLignes()
    Rows.Hidden = False
End Sub

77. Afficher toutes les colonnes masquees

Sub Macro077_AfficherColonnes()
    Columns.Hidden = False
End Sub

78. Ajuster automatiquement la largeur de toutes les colonnes

Sub Macro078_AutofitColonnes()
    Cells.EntireColumn.AutoFit
End Sub

79. Ajuster automatiquement la hauteur de toutes les lignes

Sub Macro079_AutofitLignes()
    Cells.EntireRow.AutoFit
End Sub

80. Definir la largeur d'une colonne

Sub Macro080_LargeurColonne()
    Dim l As Double
    l = InputBox("Largeur (caracteres) :")
    Selection.EntireColumn.ColumnWidth = l
End Sub

81. Definir la hauteur d'une ligne

Sub Macro081_HauteurLigne()
    Dim h As Double
    h = InputBox("Hauteur (points) :")
    Selection.EntireRow.RowHeight = h
End Sub

82. Inserer la date du jour dans la cellule active

Sub Macro082_InsererDate()
    ActiveCell.Value = Date
    ActiveCell.NumberFormat = "dd/mm/yyyy"
End Sub

83. Inserer l'heure actuelle

Sub Macro083_InsererHeure()
    ActiveCell.Value = Time
    ActiveCell.NumberFormat = "hh:mm:ss"
End Sub

84. Inserer la date et l'heure actuelles

Sub Macro084_InsererDateHeure()
    ActiveCell.Value = Now
    ActiveCell.NumberFormat = "dd/mm/yyyy hh:mm:ss"
End Sub

85. Remplir une colonne avec une suite numerique

Sub Macro085_SuiteNumerique()
    Dim debut As Long, fin As Long
    debut = InputBox("Valeur de debut :")
    fin = InputBox("Valeur de fin :")
    Dim i As Long
    For i = debut To fin
        ActiveCell.Offset(i - debut, 0).Value = i
    Next i
End Sub

86. Calculer la somme de la selection

Sub Macro086_SommeSelection()
    Dim Total As Double
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then Total = Total + c.Value
    Next c
    MsgBox "Somme = " & Total, vbInformation
End Sub

87. Calculer la moyenne de la selection

Sub Macro087_MoyenneSelection()
    Dim Total As Double, N As Long
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) And Not IsEmpty(c) Then
            Total = Total + c.Value
            N = N + 1
        End If
    Next c
    If N > 0 Then
        MsgBox "Moyenne = " & Total / N, vbInformation
    Else
        MsgBox "Aucune valeur numerique.", vbExclamation
    End If
End Sub

88. Colorer en rouge les valeurs negatives de la selection

Sub Macro088_ColorerNegatifs()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then
            If c.Value < 0 Then c.Font.Color = RGB(255, 0, 0)
        End If
    Next c
End Sub

89. Compter les occurrences d'une valeur dans la colonne A

Sub Macro089_CompterOccurrences()
    Dim Val As String
    Val = InputBox("Valeur a chercher :")
    Dim N As Long
    N = WorksheetFunction.CountIf(Columns(1), Val)
    MsgBox "Occurrences de '" & Val & "' : " & N, vbInformation
End Sub

90. Mise en evidence des cellules avec erreurs

Sub Macro090_SurlignErreurs()
    Dim c As Range
    For Each c In ActiveSheet.UsedRange
        If IsError(c.Value) Then
            c.Interior.Color = RGB(255, 200, 200)
        End If
    Next c
End Sub




' ============================================================
' ============================================================

91. Mettre en gras la selection

Sub Macro091_Gras()
    Selection.Font.Bold = True
End Sub

92. Mettre en italique la selection

Sub Macro092_Italique()
    Selection.Font.Italic = True
End Sub

93. Souligner la selection

Sub Macro093_Souligner()
    Selection.Font.Underline = xlUnderlineStyleSingle
End Sub

94. Barrer le texte de la selection

Sub Macro094_Barrer()
    Selection.Font.Strikethrough = True
End Sub

95. Changer la couleur de police en bleu

Sub Macro095_CouleurPoliceBleu()
    Selection.Font.Color = RGB(0, 0, 255)
End Sub

96. Remettre la couleur de police en noir

Sub Macro096_CouleurPoliceNoir()
    Selection.Font.ColorIndex = xlAutomatic
End Sub

97. Changer la taille de police

Sub Macro097_TaillePolice()
    Dim Taille As Integer
    Taille = InputBox("Taille de police :")
    Selection.Font.Size = Taille
End Sub

98. Changer la police

Sub Macro098_ChangePolice()
    Dim Police As String
    Police = InputBox("Nom de la police :")
    Selection.Font.Name = Police
End Sub

99. Fond jaune sur la selection

Sub Macro099_FondJaune()
    Selection.Interior.Color = RGB(255, 255, 0)
End Sub

100. Supprimer le fond (couleur de remplissage)

Sub Macro100_SupprimerFond()
    Selection.Interior.ColorIndex = xlNone
End Sub

101. Aligner a gauche

Sub Macro101_AlignGauche()
    Selection.HorizontalAlignment = xlLeft
End Sub

102. Centrer horizontalement

Sub Macro102_Centrer()
    Selection.HorizontalAlignment = xlCenter
End Sub

103. Aligner a droite

Sub Macro103_AlignDroite()
    Selection.HorizontalAlignment = xlRight
End Sub

104. Centrer verticalement

Sub Macro104_CentrerVerti()
    Selection.VerticalAlignment = xlCenter
End Sub

105. Fusionner et centrer les cellules selectionnees

Sub Macro105_FusionnerCentrer()
    With Selection
        .Merge
        .HorizontalAlignment = xlCenter
    End With
End Sub

106. Defusionner les cellules

Sub Macro106_Defusionner()
    Selection.UnMerge
End Sub

107. Activer le retour a la ligne automatique

Sub Macro107_RetourLigne()
    Selection.WrapText = True
End Sub

108. Desactiver le retour a la ligne

Sub Macro108_DesactiverRetourLigne()
    Selection.WrapText = False
End Sub

109. Ajouter une bordure autour de la selection

Sub Macro109_Bordure()
    Selection.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)
End Sub

110. Ajouter une bordure a toutes les cellules de la selection

Sub Macro110_BordureInterieure()
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Color = RGB(0, 0, 0)
    End With
End Sub

111. Supprimer toutes les bordures

Sub Macro111_SupprimerBordures()
    Selection.Borders.LineStyle = xlNone
End Sub

112. Format nombre avec 2 decimales

Sub Macro112_FormatNombre()
    Selection.NumberFormat = "#,##0.00"
End Sub

113. Format pourcentage

Sub Macro113_FormatPourcent()
    Selection.NumberFormat = "0.00%"
End Sub

114. Format devise (euro)

Sub Macro114_FormatDevise()
    Selection.NumberFormat = "#,##0.00 " & Chr(8364)
End Sub

115. Format date

Sub Macro115_FormatDate()
    Selection.NumberFormat = "dd/mm/yyyy"
End Sub

116. Format texte

Sub Macro116_FormatTexte()
    Selection.NumberFormat = "@"
End Sub

117. Appliquer un style tableau predefini

Sub Macro117_StyleTableau()
    Dim lo As ListObject
    Set lo = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
    lo.TableStyle = "TableStyleMedium9"
End Sub

118. Supprimer la mise en forme conditionnelle

Sub Macro118_SupprimerMFC()
    Selection.FormatConditions.Delete
End Sub

119. Mise en forme conditionnelle : valeurs > 100 en vert

Sub Macro119_MFC_VertSup100()
    Dim fc As FormatCondition
    With Selection
        .FormatConditions.Delete
        Set fc = .FormatConditions.Add(xlCellValue, xlGreater, 100)
        fc.Interior.Color = RGB(0, 200, 0)
    End With
End Sub

120. Mise en forme conditionnelle : barres de donnees

Sub Macro120_BarresDonnees()
    Selection.FormatConditions.AddDatabar
End Sub

121. Appliquer un degrade de couleur (nuances de couleur)

Sub Macro121_NuancesCouleur()
    Selection.FormatConditions.AddColorScale ColorScaleType:=3
End Sub

122. Retrait du texte (indentation)

Sub Macro122_Retrait()
    Selection.IndentLevel = 2
End Sub

123. Orientation du texte a 45 degres

Sub Macro123_Orientation45()
    Selection.Orientation = 45
End Sub

124. Remettre l'orientation a 0

Sub Macro124_OrientationNormale()
    Selection.Orientation = 0
End Sub

125. Appliquer une couleur de fond alternee par ligne (zebre)

Sub Macro125_ZebreTableau()
    Dim plage As Range
    Set plage = Selection
    Dim r As Range
    Dim i As Long
    i = 0
    For Each r In plage.Rows
        i = i + 1
        If i Mod 2 = 0 Then
            r.Interior.Color = RGB(220, 230, 241)
        Else
            r.Interior.ColorIndex = xlNone
        End If
    Next r
End Sub

126. Changer la couleur de fond de toute la ligne active

Sub Macro126_FondLigneActive()
    ActiveCell.EntireRow.Interior.Color = RGB(255, 255, 180)
End Sub

127. Reinitialiser toute la mise en forme de la selection

Sub Macro127_ReinitialisationMiseEnForme()
    With Selection
        .ClearFormats
        .Font.Size = 11
        .Font.Name = "Calibri"
        .HorizontalAlignment = xlGeneral
    End With
End Sub

128. Appliquer un style "Titre" a la ligne 1

Sub Macro128_StyleTitre()
    With Rows(1)
        .Font.Bold = True
        .Font.Size = 14
        .Interior.Color = RGB(0, 70, 127)
        .Font.Color = RGB(255, 255, 255)
        .RowHeight = 30
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub

129. Ajouter un double soulignement

Sub Macro129_DoubleSoulignement()
    Selection.Font.Underline = xlUnderlineStyleDouble
End Sub

130. Appliquer une police de symboles

Sub Macro130_PoliceSymboles()
    Selection.Font.Name = "Wingdings"
End Sub




' ============================================================
' ============================================================

131. Trier la colonne A en ordre croissant

Sub Macro131_TriCroissant()
    Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
End Sub

132. Trier la colonne A en ordre decroissant

Sub Macro132_TriDecroissant()
    Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes
End Sub

133. Trier par deux colonnes

Sub Macro133_TriDeuxColonnes()
    ActiveSheet.UsedRange.Sort _
        Key1:=Range("A1"), Order1:=xlAscending, _
        Key2:=Range("B1"), Order2:=xlAscending, _
        Header:=xlYes
End Sub

134. Appliquer un filtre automatique

Sub Macro134_FiltreAuto()
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    Else
        Range("A1").AutoFilter
    End If
End Sub

135. Filtrer sur une valeur specifique

Sub Macro135_Filtrer()
    Dim Val As String
    Val = InputBox("Valeur a filtrer (colonne A) :")
    Range("A1").AutoFilter Field:=1, Criteria1:=Val
End Sub

136. Effacer tous les filtres

Sub Macro136_EffacerFiltres()
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilter.ShowAllData
    End If
End Sub

137. Creer un tableau structure

Sub Macro137_CreerTableau()
    ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Tableau1"
End Sub

138. Supprimer le tableau structure (garder les donnees)

Sub Macro138_SupprimerTableau()
    Dim lo As ListObject
    For Each lo In ActiveSheet.ListObjects
        lo.Unlist
    Next lo
End Sub

139. Validation des donnees (liste deroulante)

Sub Macro139_ValidationListe()
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="Oui,Non,N/A"
        .ShowInput = True
        .ShowError = True
    End With
End Sub

140. Validation des donnees (nombre entier entre 1 et 100)

Sub Macro140_ValidationNombre()
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="1", Formula2:="100"
    End With
End Sub

141. Supprimer la validation des donnees

Sub Macro141_SupprimerValidation()
    Selection.Validation.Delete
End Sub

142. Importer des donnees CSV

Sub Macro142_ImporterCSV()
    Dim Chemin As String
    Chemin = Application.GetOpenFilename("Fichiers CSV (*.csv),*.csv")
    If Chemin <> "False" Then
        Workbooks.Open Filename:=Chemin, Format:=2
    End If
End Sub

143. Convertir le texte en colonnes (delimiteur virgule)

Sub Macro143_TexteEnColonnes()
    Selection.TextToColumns Destination:=Selection.Cells(1, 1), _
        DataType:=xlDelimited, Comma:=True
End Sub

144. Grouper des lignes

Sub Macro144_GrouperLignes()
    Selection.Rows.Group
End Sub

145. Degrouper des lignes

Sub Macro145_DegroupLignes()
    Selection.Rows.Ungroup
End Sub

146. Creer un sous-total

Sub Macro146_SousTotal()
    ActiveSheet.UsedRange.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2)
End Sub

147. Supprimer les sous-totaux

Sub Macro147_SupprimerSousTotal()
    ActiveSheet.UsedRange.RemoveSubtotal
End Sub

148. Creer un tableau croise dynamique (basic)

Sub Macro148_TableauCroise()
    Dim wsDest As Worksheet
    Set wsDest = Sheets.Add
    wsDest.Name = "TCD"
    Dim cache As PivotCache
    Set cache = ActiveWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=Sheets(1).UsedRange)
    cache.CreatePivotTable TableDestination:=wsDest.Cells(1, 1), TableName:="TCD1"
End Sub

149. Actualiser tous les tableaux croises dynamiques

Sub Macro149_ActualiserTCD()
    Dim pt As PivotTable
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        For Each pt In sh.PivotTables
            pt.RefreshTable
        Next pt
    Next sh
End Sub

150. Rechercher une valeur avec VLOOKUP (via MsgBox)

Sub Macro150_RechercheVLookup()
    Dim Val As String
    Val = InputBox("Valeur a rechercher (colonne A) :")
    On Error Resume Next
    Dim Resultat As Variant
    Resultat = WorksheetFunction.VLookup(Val, ActiveSheet.UsedRange, 2, False)
    If Err.Number <> 0 Then
        MsgBox "Valeur introuvable !", vbExclamation
    Else
        MsgBox "Resultat colonne B : " & Resultat, vbInformation
    End If
    On Error GoTo 0
End Sub

151. Mettre en evidence les doublons

Sub Macro151_SurlignDoublons()
    Dim plage As Range
    Set plage = Selection
    Dim c As Range
    For Each c In plage
        If WorksheetFunction.CountIf(plage, c.Value) > 1 Then
            c.Interior.Color = RGB(255, 199, 206)
        End If
    Next c
End Sub

152. Extraire les valeurs uniques vers la colonne E

Sub Macro152_ExtraireUniques()
    Dim plage As Range
    Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Dim coll As New Collection
    Dim c As Range
    On Error Resume Next
    For Each c In plage
        coll.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Dim i As Long
    For i = 1 To coll.Count
        Cells(i, 5).Value = coll(i)
    Next i
End Sub

153. Compter les valeurs uniques dans la colonne A

Sub Macro153_CompterUniques()
    Dim plage As Range
    Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Dim coll As New Collection
    Dim c As Range
    On Error Resume Next
    For Each c In plage
        coll.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    MsgBox "Valeurs uniques : " & coll.Count, vbInformation
End Sub

154. Remplir les cellules vides par 0

Sub Macro154_RemplirPar0()
    Dim plage As Range
    On Error Resume Next
    Set plage = Selection.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not plage Is Nothing Then plage.Value = 0
End Sub

155. Convertir les dates texte en vraies dates

Sub Macro155_ConvertirDates()
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then
            On Error Resume Next
            c.Value = CDate(c.Value)
            c.NumberFormat = "dd/mm/yyyy"
            On Error GoTo 0
        End If
    Next c
End Sub

156. Convertir les nombres stockes en texte en nombres

Sub Macro156_TexteEnNombre()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then c.Value = c.Value * 1
    Next c
End Sub

157. Extraire les 3 premiers caracteres de chaque cellule

Sub Macro157_Extraire3Premiers()
    Dim c As Range
    Dim i As Long
    i = 1
    For Each c In Selection
        Cells(i, ActiveCell.Column + 1).Value = Left(c.Value, 3)
        i = i + 1
    Next c
End Sub

158. Concatener les colonnes A et B dans C

Sub Macro158_Concatener()
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
    Dim i As Long
    For i = 1 To DerLigne
        Cells(i, 3).Value = Cells(i, 1).Value & " " & Cells(i, 2).Value
    Next i
End Sub

159. Separer Prenom et Nom (sur espace) vers colonnes B et C

Sub Macro159_SeparerPrenomNom()
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
    Dim i As Long
    Dim Espace As Integer
    For i = 1 To DerLigne
        Espace = InStr(Cells(i, 1).Value, " ")
        If Espace > 0 Then
            Cells(i, 2).Value = Left(Cells(i, 1).Value, Espace - 1)
            Cells(i, 3).Value = Mid(Cells(i, 1).Value, Espace + 1)
        End If
    Next i
End Sub

160. Ajouter un prefixe a toutes les cellules de la selection

Sub Macro160_AjouterPrefixe()
    Dim Prefixe As String
    Prefixe = InputBox("Prefixe a ajouter :")
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = Prefixe & c.Value
    Next c
End Sub

161. Ajouter un suffixe a toutes les cellules de la selection

Sub Macro161_AjouterSuffixe()
    Dim Suffixe As String
    Suffixe = InputBox("Suffixe a ajouter :")
    Dim c As Range
    For Each c In Selection
        If Not IsEmpty(c) Then c.Value = c.Value & Suffixe
    Next c
End Sub

162. Multiplier toutes les valeurs de la selection par un facteur

Sub Macro162_Multiplier()
    Dim Facteur As Double
    Facteur = InputBox("Facteur de multiplication :")
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then c.Value = c.Value * Facteur
    Next c
End Sub

163. Calculer la mediane de la colonne A

Sub Macro163_Mediane()
    Dim plage As Range
    Set plage = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    MsgBox "Mediane : " & WorksheetFunction.Median(plage), vbInformation
End Sub

164. Trouver la valeur maximale et la cellule correspondante

Sub Macro164_ValeurMax()
    Dim plage As Range
    Set plage = Selection
    Dim MaxVal As Double
    MaxVal = WorksheetFunction.Max(plage)
    Dim c As Range
    For Each c In plage
        If c.Value = MaxVal Then
            MsgBox "Max = " & MaxVal & " en " & c.Address, vbInformation
            Exit Sub
        End If
    Next c
End Sub

165. Trouver la valeur minimale et la cellule correspondante

Sub Macro165_ValeurMin()
    Dim plage As Range
    Set plage = Selection
    Dim MinVal As Double
    MinVal = WorksheetFunction.Min(plage)
    Dim c As Range
    For Each c In plage
        If c.Value = MinVal Then
            MsgBox "Min = " & MinVal & " en " & c.Address, vbInformation
            Exit Sub
        End If
    Next c
End Sub

166. Generer des nombres aleatoires dans la selection

Sub Macro166_NombresAleatoires()
    Dim Min As Double, Max As Double
    Min = InputBox("Minimum :")
    Max = InputBox("Maximum :")
    Dim c As Range
    For Each c In Selection
        c.Value = Int((Max - Min + 1) * Rnd + Min)
    Next c
End Sub

167. Classer les valeurs de la selection (rang)

Sub Macro167_Rang()
    Dim plage As Range
    Set plage = Selection
    Dim c As Range
    For Each c In plage
        If IsNumeric(c.Value) Then
            c.Offset(0, 1).Value = WorksheetFunction.Rank(c.Value, plage, 0)
        End If
    Next c
End Sub

168. Supprimer les lignes dont la cellule A est vide

Sub Macro168_SupprimerLignesVidesA()
    Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If IsEmpty(Cells(i, 1)) Then Rows(i).Delete
    Next i
End Sub

169. Supprimer les lignes contenant un mot specifique dans la colonne A

Sub Macro169_SupprimerLignesMot()
    Dim Mot As String
    Mot = InputBox("Mot a rechercher pour supprimer la ligne :")
    Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If InStr(1, CStr(Cells(i, 1).Value), Mot, vbTextCompare) > 0 Then
            Rows(i).Delete
        End If
    Next i
End Sub

170. Copier uniquement les lignes filtrees dans une nouvelle feuille

Sub Macro170_CopierLignesFiltrees()
    Dim shDest As Worksheet
    Set shDest = Sheets.Add
    shDest.Name = "Filtre_" & Format(Now, "hhmmss")
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy shDest.Range("A1")
    MsgBox "Lignes filtrees copiees dans la feuille '" & shDest.Name & "'.", vbInformation
End Sub




' ============================================================
' ============================================================

171. Inserer une formule SOMME dans la cellule selectionnee

Sub Macro171_FormulerSomme()
    ActiveCell.Formula = "=SUM(A1:A10)"
End Sub

172. Inserer une formule MOYENNE

Sub Macro172_FormulerMoyenne()
    ActiveCell.Formula = "=AVERAGE(A1:A10)"
End Sub

173. Inserer une formule SI simple

Sub Macro173_FormulerSi()
    ActiveCell.Formula = "=IF(A1>0,""Positif"",""Negatif"")"
End Sub

174. Inserer une formule RECHERCHEV

Sub Macro174_FormulerRecV()
    ActiveCell.Formula = "=VLOOKUP(A1,Sheet2!A:B,2,FALSE)"
End Sub

175. Inserer une formule NB.SI

Sub Macro175_FormulerNbSi()
    ActiveCell.Formula = "=COUNTIF(A:A,A1)"
End Sub

176. Inserer une formule SOMME.SI

Sub Macro176_FormulerSommeSi()
    ActiveCell.Formula = "=SUMIF(A:A,A1,B:B)"
End Sub

177. Calculer le taux de TVA (20%)

Sub Macro177_CalculTVA()
    Dim HT As Double
    HT = InputBox("Montant HT :")
    MsgBox "TVA (20%) : " & HT * 0.2 & Chr(10) & "TTC : " & HT * 1.2, vbInformation
End Sub

178. Calculer un pourcentage

Sub Macro178_CalculPourcentage()
    Dim Total As Double, Partie As Double
    Total = InputBox("Total :")
    Partie = InputBox("Partie :")
    If Total <> 0 Then
        MsgBox "Pourcentage : " & Format(Partie / Total, "0.00%"), vbInformation
    End If
End Sub

179. Convertir les degres Celsius en Fahrenheit

Sub Macro179_CelsiusFahrenheit()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then
            c.Offset(0, 1).Value = c.Value * 9 / 5 + 32
        End If
    Next c
End Sub

180. Convertir les kilometres en miles

Sub Macro180_KmMiles()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then
            c.Offset(0, 1).Value = Round(c.Value * 0.621371, 2)
        End If
    Next c
End Sub

181. Calculer la valeur future d'un investissement

Sub Macro181_ValeurFuture()
    Dim Taux As Double, NPeriodes As Integer
    Dim VA As Double
    Taux = InputBox("Taux d'interet annuel (ex: 0.05) :")
    NPeriodes = InputBox("Nombre d'annees :")
    VA = InputBox("Valeur actuelle :")
    MsgBox "Valeur future : " & Format(-FV(Taux, NPeriodes, 0, VA), "#,##0.00"), vbInformation
End Sub

182. Calculer la mensualite d'un pret

Sub Macro182_Mensualite()
    Dim Taux As Double, N As Integer, Capital As Double
    Taux = InputBox("Taux annuel (ex: 0.05) :") / 12
    N = InputBox("Duree en mois :")
    Capital = InputBox("Capital emprunte :")
    MsgBox "Mensualite : " & Format(Pmt(Taux, N, -Capital), "#,##0.00"), vbInformation
End Sub

183. Calculer la racine carree de chaque cellule

Sub Macro183_RacineCarree()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) And c.Value >= 0 Then
            c.Offset(0, 1).Value = Sqr(c.Value)
        End If
    Next c
End Sub

184. Arrondir les valeurs de la selection a 2 decimales

Sub Macro184_Arrondir()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then
            c.Value = Round(c.Value, 2)
        End If
    Next c
End Sub

185. Calculer l'ecart-type

Sub Macro185_EcartType()
    MsgBox "Ecart-type : " & _
        WorksheetFunction.StDev(Selection), vbInformation
End Sub

186. Recalculer toutes les formules du classeur

Sub Macro186_Recalculer()
    Application.CalculateFull
End Sub

187. Activer le calcul automatique

Sub Macro187_CalcAuto()
    Application.Calculation = xlCalculationAutomatic
End Sub

188. Activer le calcul manuel

Sub Macro188_CalcManuel()
    Application.Calculation = xlCalculationManual
End Sub

189. Inserer une formule INDEX/EQUIV

Sub Macro189_IndexEquiv()
    ActiveCell.Formula = "=INDEX(B:B,MATCH(A1,A:A,0))"
End Sub

190. Calculer le nombre de jours entre deux dates

Sub Macro190_NbJours()
    Dim d1 As Date, d2 As Date
    d1 = InputBox("Date de debut (jj/mm/aaaa) :")
    d2 = InputBox("Date de fin (jj/mm/aaaa) :")
    MsgBox "Nombre de jours : " & DateDiff("d", d1, d2), vbInformation
End Sub

191. Calculer l'age a partir de la date de naissance

Sub Macro191_CalculAge()
    Dim dNaiss As Date
    dNaiss = InputBox("Date de naissance (jj/mm/aaaa) :")
    MsgBox "Age : " & DateDiff("yyyy", dNaiss, Date) & " ans", vbInformation
End Sub

192. Calculer le nombre de jours ouvres entre deux dates

Sub Macro192_JoursOuvres()
    Dim d1 As Date, d2 As Date
    d1 = InputBox("Date de debut :")
    d2 = InputBox("Date de fin :")
    MsgBox "Jours ouvres : " & _
        WorksheetFunction.NetworkDays(d1, d2), vbInformation
End Sub

193. Generer la table de multiplication

Sub Macro193_TableMultiplication()
    Dim n As Integer
    n = InputBox("Nombre (1 a 10) :")
    Dim i As Integer
    For i = 1 To 10
        Cells(i, 1).Value = n & " x " & i & " = " & n * i
    Next i
End Sub

194. Suite de Fibonacci

Sub Macro194_Fibonacci()
    Dim N As Integer
    N = InputBox("Combien de termes ?")
    If N < 1 Then Exit Sub
    Cells(1, 1).Value = 1
    If N > 1 Then Cells(2, 1).Value = 1
    Dim i As Long
    For i = 3 To N
        Cells(i, 1).Value = Cells(i - 1, 1).Value + Cells(i - 2, 1).Value
    Next i
End Sub

195. Calculer l'amortissement lineaire

Sub Macro195_Amortissement()
    Dim Valeur As Double, Rebut As Double, Vie As Double
    Valeur = InputBox("Valeur d'achat :")
    Rebut = InputBox("Valeur residuelle :")
    Vie = InputBox("Duree de vie (annees) :")
    MsgBox "Amortissement annuel (lineaire) : " & _
        Format((Valeur - Rebut) / Vie, "#,##0.00"), vbInformation
End Sub

196. Calculer le PGCD de deux nombres

Sub Macro196_PGCD()
    Dim a As Long, b As Long
    a = InputBox("Premier nombre :")
    b = InputBox("Deuxieme nombre :")
    MsgBox "PGCD : " & WorksheetFunction.Gcd(a, b), vbInformation
End Sub

197. Calculer le PPCM de deux nombres

Sub Macro197_PPCM()
    Dim a As Long, b As Long
    a = InputBox("Premier nombre :")
    b = InputBox("Deuxieme nombre :")
    MsgBox "PPCM : " & WorksheetFunction.Lcm(a, b), vbInformation
End Sub

198. Convertir un nombre en chiffres romains

Sub Macro198_ChiffresRomains()
    Dim n As Long
    n = InputBox("Nombre a convertir :")
    MsgBox "Chiffres romains : " & WorksheetFunction.Roman(n), vbInformation
End Sub

199. Inserer des formules de somme cumulative

Sub Macro199_SommeCumulative()
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
    Cells(1, 2).Value = Cells(1, 1).Value
    Dim i As Long
    For i = 2 To DerLigne
        Cells(i, 2).Formula = "=B" & (i - 1) & "+A" & i
    Next i
End Sub

200. Calculer la variance de la selection

Sub Macro200_Variance()
    MsgBox "Variance : " & WorksheetFunction.Var(Selection), vbInformation
End Sub




' ============================================================
' ============================================================

201. Creer un graphique en courbes

Sub Macro201_GraphCourbes()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlLine
    ch.SetSourceData Source:=Selection
End Sub

202. Creer un graphique en barres

Sub Macro202_GraphBarres()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlColumnClustered
    ch.SetSourceData Source:=Selection
End Sub

203. Creer un graphique en secteurs (camembert)

Sub Macro203_GraphCamembert()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlPie
    ch.SetSourceData Source:=Selection
End Sub

204. Creer un graphique en barres horizontales

Sub Macro204_GraphBarresHoriz()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlBarClustered
    ch.SetSourceData Source:=Selection
End Sub

205. Creer un graphique en aires

Sub Macro205_GraphAires()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlArea
    ch.SetSourceData Source:=Selection
End Sub

206. Inserer un graphique incorpore dans la feuille active

Sub Macro206_GraphIncorpore()
    Dim chObj As ChartObject
    Set chObj = ActiveSheet.ChartObjects.Add(Left:=50, Top:=50, Width:=400, Height:=250)
    chObj.Chart.ChartType = xlColumnClustered
    chObj.Chart.SetSourceData Source:=Selection
End Sub

207. Changer le titre du graphique

Sub Macro207_TitreGraphique()
    Dim Titre As String
    Titre = InputBox("Nouveau titre :")
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Text = Titre
    End With
End Sub

208. Ajouter des etiquettes de donnees

Sub Macro208_EtiquettesDonnees()
    Dim ser As Series
    For Each ser In ActiveChart.SeriesCollection
        ser.HasDataLabels = True
    Next ser
End Sub

209. Supprimer toutes les etiquettes

Sub Macro209_SuppEtiquettes()
    Dim ser As Series
    For Each ser In ActiveChart.SeriesCollection
        ser.HasDataLabels = False
    Next ser
End Sub

210. Afficher la legende du graphique

Sub Macro210_AfficherLegende()
    ActiveChart.HasLegend = True
End Sub

211. Supprimer la legende

Sub Macro211_SupprimerLegende()
    ActiveChart.HasLegend = False
End Sub

212. Changer la couleur de la premiere serie

Sub Macro212_CouleurSerie()
    ActiveChart.SeriesCollection(1).Interior.Color = RGB(0, 112, 192)
End Sub

213. Exporter le graphique en image PNG

Sub Macro213_ExporterGraphique()
    Dim chObj As ChartObject
    For Each chObj In ActiveSheet.ChartObjects
        chObj.Chart.Export Environ("USERPROFILE") & "\Desktop\" & chObj.Name & ".png"
    Next chObj
    MsgBox "Graphique(s) exporte(s) sur le bureau.", vbInformation
End Sub

214. Redimensionner tous les graphiques

Sub Macro214_RedimGraphiques()
    Dim chObj As ChartObject
    For Each chObj In ActiveSheet.ChartObjects
        chObj.Width = 400
        chObj.Height = 250
    Next chObj
End Sub

215. Deplacer tous les graphiques

Sub Macro215_DeplacerGraphiques()
    Dim chObj As ChartObject
    Dim i As Integer
    i = 0
    For Each chObj In ActiveSheet.ChartObjects
        chObj.Left = 50 + i * 420
        chObj.Top = 50
        i = i + 1
    Next chObj
End Sub

216. Supprimer tous les graphiques de la feuille

Sub Macro216_SupprimerGraphiques()
    Dim chObj As ChartObject
    For Each chObj In ActiveSheet.ChartObjects
        chObj.Delete
    Next chObj
End Sub

217. Changer le type de tous les graphiques en courbes

Sub Macro217_TypeCourbes()
    Dim chObj As ChartObject
    For Each chObj In ActiveSheet.ChartObjects
        chObj.Chart.ChartType = xlLine
    Next chObj
End Sub

218. Actualiser la source de donnees du premier graphique

Sub Macro218_ActualiserGraphique()
    ActiveSheet.ChartObjects(1).Chart.SetSourceData Source:=Selection
End Sub

219. Creer un graphique Nuage de points (XY)

Sub Macro219_GraphNuagePoints()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlXYScatter
    ch.SetSourceData Source:=Selection
End Sub

220. Creer un graphique sparkline (tendance)

Sub Macro220_Sparklines()
    ActiveSheet.SparklineGroups.Add _
        Type:=xlSparkLine, _
        SourceData:=Selection.Address, _
        DestinationRange:=ActiveCell.Offset(0, Selection.Columns.Count + 1)
End Sub




' ============================================================
' ============================================================

221. Afficher un message simple

Sub Macro221_MsgBox()
    MsgBox "Bonjour depuis VBA !", vbInformation, "Information"
End Sub

222. Demander une confirmation Oui/Non

Sub Macro222_Confirmation()
    If MsgBox("Confirmer l'action ?", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
        MsgBox "Action confirmee !", vbInformation
    Else
        MsgBox "Action annulee.", vbExclamation
    End If
End Sub

223. Saisir une valeur via InputBox

Sub Macro223_InputBox()
    Dim val As String
    val = InputBox("Entrez une valeur :", "Saisie", "Valeur par defaut")
    If val <> "" Then ActiveCell.Value = val
End Sub

224. Selectionner une plage via InputBox

Sub Macro224_InputBoxPlage()
    Dim plage As Range
    On Error Resume Next
    Set plage = Application.InputBox("Selectionnez une plage :", Type:=8)
    On Error GoTo 0
    If Not plage Is Nothing Then plage.Select
End Sub

225. Afficher un message avec icone d'erreur

Sub Macro225_MsgErreur()
    MsgBox "Une erreur est survenue !", vbCritical, "Erreur"
End Sub

226. Afficher un message avec minuterie (disparait apres 3s)

Sub Macro226_MsgTemporise()
    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    wsh.Popup "Ce message disparait dans 3 secondes !", 3, "Info", vbInformation
End Sub

227. Afficher une barre de progression dans la barre de statut

Sub Macro227_BarreProgression()
    Dim i As Long
    For i = 1 To 100
        Application.StatusBar = "Progression : " & i & "%"
    Next i
    Application.StatusBar = False
End Sub

228. Ouvrir la boite de dialogue de couleur

Sub Macro228_BoiteDialogueCouleur()
    Application.Dialogs(xlDialogFormatCells).Show
End Sub

229. Ouvrir la boite de dialogue Police

Sub Macro229_BoiteDialoguePolice()
    Application.Dialogs(xlDialogFont).Show
End Sub

230. Ouvrir la boite de dialogue Mise en page

Sub Macro230_BoiteMiseEnPage()
    Application.Dialogs(xlDialogPageSetup).Show
End Sub

231. Ouvrir la boite de dialogue Imprimer

Sub Macro231_BoiteImprimer()
    Application.Dialogs(xlDialogPrint).Show
End Sub

232. Afficher un menu personnalise via InputBox liste

Sub Macro232_MenuPersonnalise()
    Dim Choix As String
    Choix = InputBox("Choisissez :" & Chr(10) & _
        "1 - Trier" & Chr(10) & "2 - Filtrer" & Chr(10) & "3 - Copier", "Menu")
    Select Case Choix
        Case "1" : Macro131_TriCroissant
        Case "2" : Macro134_FiltreAuto
        Case "3" : MsgBox "Copie en cours...", vbInformation
        Case Else : MsgBox "Choix invalide.", vbExclamation
    End Select
End Sub

233. Afficher les informations systeme

Sub Macro233_InfoSysteme()
    MsgBox "Utilisateur : " & Application.UserName & Chr(10) & _
           "Version Excel : " & Application.Version & Chr(10) & _
           "Systeme : " & Application.OperatingSystem & Chr(10) & _
           "Date : " & Date & " | Heure : " & Time, _
           vbInformation, "Informations systeme"
End Sub

234. Compteur cliquable dans une cellule

Sub Macro234_Compteur()
    ActiveCell.Value = ActiveCell.Value + 1
End Sub

235. Demander un mot de passe avant execution

Sub Macro235_DemanderMdp()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe :", "Securite")
    If Mdp = "secret123" Then
        MsgBox "Acces autorise !", vbInformation
    Else
        MsgBox "Mot de passe incorrect !", vbCritical
    End If
End Sub

236. Afficher l'aide personnalisee

Sub Macro236_AidePersonnalisee()
    MsgBox "=== AIDE ===" & Chr(10) & Chr(10) & _
        "Ce fichier contient 300 macros VBA Excel." & Chr(10) & _
        "Pour executer : Alt+F8 > Selectionner la macro > Executer.", _
        vbInformation, "Aide"
End Sub

237. Creer une liste de controle interactive

Sub Macro237_CheckList()
    Dim Items As Variant
    Items = Array("Verifier les donnees", "Formater le tableau", "Creer le graphique", "Exporter en PDF")
    Dim i As Integer
    Dim Resultat As String
    For i = 0 To UBound(Items)
        If MsgBox(Items(i) & " - Termine ?", vbYesNo + vbQuestion, "Check-list") = vbYes Then
            Resultat = Resultat & "OK : " & Items(i) & Chr(10)
        Else
            Resultat = Resultat & "A faire : " & Items(i) & Chr(10)
        End If
    Next i
    MsgBox "Recapitulatif :" & Chr(10) & Resultat, vbInformation, "Check-list"
End Sub

238. Afficher des statistiques rapides

Sub Macro238_StatsRapides()
    If Selection.Cells.Count < 2 Then
        MsgBox "Selectionnez au moins 2 cellules numeriques.", vbExclamation
        Exit Sub
    End If
    MsgBox "Statistiques sur la selection :" & Chr(10) & Chr(10) & _
        "Somme : " & WorksheetFunction.Sum(Selection) & Chr(10) & _
        "Moyenne : " & Round(WorksheetFunction.Average(Selection), 2) & Chr(10) & _
        "Min : " & WorksheetFunction.Min(Selection) & Chr(10) & _
        "Max : " & WorksheetFunction.Max(Selection) & Chr(10) & _
        "Nb valeurs : " & WorksheetFunction.Count(Selection), _
        vbInformation, "Statistiques"
End Sub

239. Boite de dialogue pour choisir une feuille

Sub Macro239_ChoisirFeuille()
    Dim Choix As String
    Dim Liste As String
    Dim sh As Worksheet
    For Each sh In Sheets
        Liste = Liste & sh.Name & Chr(10)
    Next sh
    Choix = InputBox("Feuilles disponibles :" & Chr(10) & Liste & Chr(10) & "Entrez le nom :", "Navigation")
    If Choix <> "" Then
        On Error Resume Next
        Sheets(Choix).Activate
        If Err.Number <> 0 Then MsgBox "Feuille introuvable !", vbExclamation
        On Error GoTo 0
    End If
End Sub

240. Afficher un resume de la feuille active

Sub Macro240_ResumeFeuille()
    Dim DerLigne As Long, DerCol As Long
    DerLigne = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    DerCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
    MsgBox "Feuille : " & ActiveSheet.Name & Chr(10) & _
           "Derniere ligne : " & DerLigne & Chr(10) & _
           "Derniere colonne : " & DerCol & Chr(10) & _
           "Cellules utilisees : " & ActiveSheet.UsedRange.Cells.Count, _
           vbInformation, "Resume"
End Sub




' ============================================================
' ============================================================

241. Lister tous les fichiers d'un dossier

Sub Macro241_ListerFichiers()
    Dim Chemin As String
    Chemin = InputBox("Chemin du dossier (ex: C:\Mes Documents\) :")
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
    Dim fichier As String
    fichier = Dir(Chemin & "*.*")
    Dim i As Long
    i = 1
    Do While fichier <> ""
        Cells(i, 1).Value = fichier
        i = i + 1
        fichier = Dir()
    Loop
    MsgBox i - 1 & " fichier(s) liste(s).", vbInformation
End Sub

242. Verifier si un fichier existe

Sub Macro242_VerifierFichier()
    Dim Chemin As String
    Chemin = InputBox("Chemin complet du fichier :")
    If Dir(Chemin) <> "" Then
        MsgBox "Le fichier existe.", vbInformation
    Else
        MsgBox "Fichier introuvable !", vbExclamation
    End If
End Sub

243. Creer un dossier

Sub Macro243_CreerDossier()
    Dim Chemin As String
    Chemin = InputBox("Chemin du nouveau dossier :")
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir Chemin
        MsgBox "Dossier cree : " & Chemin, vbInformation
    Else
        MsgBox "Le dossier existe deja.", vbExclamation
    End If
End Sub

244. Supprimer un fichier

Sub Macro244_SupprimerFichier()
    Dim Chemin As String
    Chemin = InputBox("Chemin du fichier a supprimer :")
    If Dir(Chemin) <> "" Then
        If MsgBox("Supprimer " & Chemin & " ?", vbYesNo) = vbYes Then
            Kill Chemin
            MsgBox "Fichier supprime.", vbInformation
        End If
    Else
        MsgBox "Fichier introuvable !", vbExclamation
    End If
End Sub

245. Renommer un fichier

Sub Macro245_RenommerFichier()
    Dim Ancien As String, Nouveau As String
    Ancien = InputBox("Chemin actuel du fichier :")
    Nouveau = InputBox("Nouveau chemin/nom :")
    If Dir(Ancien) <> "" Then
        Name Ancien As Nouveau
        MsgBox "Fichier renomme.", vbInformation
    Else
        MsgBox "Fichier introuvable !", vbExclamation
    End If
End Sub

246. Copier un fichier

Sub Macro246_CopierFichier()
    Dim Source As String, Dest As String
    Source = InputBox("Chemin source :")
    Dest = InputBox("Chemin destination :")
    If Dir(Source) <> "" Then
        FileCopy Source, Dest
        MsgBox "Fichier copie.", vbInformation
    Else
        MsgBox "Fichier source introuvable !", vbExclamation
    End If
End Sub

247. Ecrire dans un fichier texte

Sub Macro247_EcrireFichierTexte()
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\sortie.txt"
    Dim numFichier As Integer
    numFichier = FreeFile
    Open Chemin For Output As #numFichier
    Dim c As Range
    For Each c In Selection
        Print #numFichier, c.Value
    Next c
    Close #numFichier
    MsgBox "Fichier cree : " & Chemin, vbInformation
End Sub

248. Lire un fichier texte et l'importer dans la feuille

Sub Macro248_LireFichierTexte()
    Dim Chemin As String
    Chemin = Application.GetOpenFilename("Fichiers texte (*.txt),*.txt")
    If Chemin = "False" Then Exit Sub
    Dim numFichier As Integer
    numFichier = FreeFile
    Open Chemin For Input As #numFichier
    Dim Ligne As String
    Dim i As Long
    i = 1
    Do While Not EOF(numFichier)
        Line Input #numFichier, Ligne
        Cells(i, 1).Value = Ligne
        i = i + 1
    Loop
    Close #numFichier
End Sub

249. Ouvrir un dossier dans l'explorateur Windows

Sub Macro249_OuvrirExplorateur()
    Dim Chemin As String
    Chemin = InputBox("Chemin du dossier :")
    Shell "explorer.exe """ & Chemin & """", vbNormalFocus
End Sub

250. Obtenir le chemin du bureau

Sub Macro250_CheminBureau()
    MsgBox "Bureau : " & Environ("USERPROFILE") & "\Desktop", vbInformation
End Sub

251. Lister tous les classeurs ouverts

Sub Macro251_ListeClasseursOuverts()
    Dim wb As Workbook
    Dim i As Long
    i = 1
    For Each wb In Workbooks
        Cells(i, 1).Value = wb.Name
        Cells(i, 2).Value = wb.FullName
        i = i + 1
    Next wb
End Sub

252. Sauvegarder une copie horodatee

Sub Macro252_SauvegardeHorodatee()
    Dim Timestamp As String
    Timestamp = Format(Now, "yyyymmdd_hhmmss")
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\Backup_" & Timestamp & ".xlsx"
    ActiveWorkbook.SaveCopyAs Chemin
    MsgBox "Sauvegarde : " & Chemin, vbInformation
End Sub

253. Ouvrir une URL dans le navigateur par defaut

Sub Macro253_OuvrirURL()
    Dim URL As String
    URL = InputBox("Entrez l'URL :")
    If URL <> "" Then
        Shell "cmd /c start """ & URL & """", vbHide
    End If
End Sub

254. Exporter la feuille active en CSV

Sub Macro254_ExporterCSV2()
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".csv"
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=Chemin, FileFormat:=xlCSV
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "CSV exporte : " & Chemin, vbInformation
End Sub

255. Afficher la taille du classeur actif

Sub Macro255_TailleClasseur()
    If ActiveWorkbook.FullName <> ActiveWorkbook.Name Then
        MsgBox "Taille : " & Format(FileLen(ActiveWorkbook.FullName) / 1024, "0.00") & " Ko", vbInformation
    Else
        MsgBox "Sauvegardez d'abord le classeur.", vbExclamation
    End If
End Sub

256. Envoyer un email via Outlook (si installe)

Sub Macro256_EnvoyerEmail()
    Dim oApp As Object, oMail As Object
    On Error GoTo ErreurOutlook
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
        .To = InputBox("Destinataire :")
        .Subject = InputBox("Sujet :")
        .Body = InputBox("Corps du message :")
        .Display
    End With
    Exit Sub
ErreurOutlook:
    MsgBox "Outlook n'est pas disponible.", vbExclamation
End Sub

257. Attacher le classeur actif a un email

Sub Macro257_AttacherClasseur()
    Dim oApp As Object, oMail As Object
    On Error GoTo ErreurOutlook
    ActiveWorkbook.Save
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
        .To = InputBox("Destinataire :")
        .Subject = ActiveWorkbook.Name
        .Attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    Exit Sub
ErreurOutlook:
    MsgBox "Outlook n'est pas disponible.", vbExclamation
End Sub

258. Lire/ecrire dans le registre Windows

Sub Macro258_RegistreWindows()
    SaveSetting "MonAppExcel", "Parametres", "Couleur", "Bleu"
    Dim Valeur As String
    Valeur = GetSetting("MonAppExcel", "Parametres", "Couleur", "Non defini")
    MsgBox "Valeur registre : " & Valeur, vbInformation
End Sub

259. Calculer la taille d'un fichier

Sub Macro259_TailleFichier()
    Dim Chemin As String
    Chemin = Application.GetOpenFilename()
    If Chemin <> "False" Then
        MsgBox "Taille : " & Format(FileLen(Chemin) / 1024, "0.00") & " Ko", vbInformation
    End If
End Sub

260. Sauvegarder et fermer tous les classeurs sauf celui-ci

Sub Macro260_SauvegarderFermerTous()
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then
            wb.Close SaveChanges:=True
        End If
    Next wb
    MsgBox "Tous les autres classeurs ont ete sauvegardes et fermes.", vbInformation
End Sub




' ============================================================
' ============================================================

261. Imprimer la feuille active

Sub Macro261_Imprimer()
    ActiveSheet.PrintOut
End Sub

262. Apercu avant impression

Sub Macro262_Apercu()
    ActiveSheet.PrintPreview
End Sub

263. Definir la zone d'impression

Sub Macro263_ZoneImpression()
    ActiveSheet.PageSetup.PrintArea = Selection.Address
End Sub

264. Effacer la zone d'impression

Sub Macro264_EffacerZoneImpression()
    ActiveSheet.PageSetup.PrintArea = ""
End Sub

265. Orientation paysage

Sub Macro265_Paysage()
    ActiveSheet.PageSetup.Orientation = xlLandscape
End Sub

266. Orientation portrait

Sub Macro266_Portrait()
    ActiveSheet.PageSetup.Orientation = xlPortrait
End Sub

267. Ajuster a 1 page de large

Sub Macro267_AjusterPage()
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
End Sub

268. Ajouter un en-tete personnalise

Sub Macro268_EnTete()
    ActiveSheet.PageSetup.LeftHeader = ActiveSheet.Name
    ActiveSheet.PageSetup.CenterHeader = "&D"
    ActiveSheet.PageSetup.RightHeader = "Page &P / &N"
End Sub

269. Ajouter un pied de page

Sub Macro269_PiedDePage()
    ActiveSheet.PageSetup.CenterFooter = "Confidentiel - " & ActiveWorkbook.Name
End Sub

270. Imprimer toutes les feuilles du classeur

Sub Macro270_ImprimerTout()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        sh.PrintOut
    Next sh
End Sub




' ============================================================
' ============================================================

271. Desactiver les alertes et recalcul pendant une macro (template)

Sub Macro271_OptimiserVitesse()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    ' --- Votre code ici ---
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

272. Mesurer le temps d'execution d'une macro

Sub Macro272_MesureTemps()
    Dim Debut As Double
    Debut = Timer
    ' --- Votre code ici ---
    Dim Fin As Double
    Fin = Timer
    MsgBox "Temps d'execution : " & Round(Fin - Debut, 3) & " secondes", vbInformation
End Sub

273. Pause d'une seconde

Sub Macro273_Pause()
    Application.Wait (Now + TimeValue("0:00:01"))
    MsgBox "1 seconde ecoulee.", vbInformation
End Sub

274. Repeter une action N fois

Sub Macro274_RepeterN()
    Dim N As Integer
    N = InputBox("Combien de fois ?")
    Dim i As Integer
    For i = 1 To N
        Cells(i, 1).Value = "Iteration " & i
    Next i
End Sub

275. Planifier une macro a une heure precise

Sub Macro275_PlanifierMacro()
    Application.OnTime TimeValue("09:00:00"), "Macro221_MsgBox"
    MsgBox "Macro planifiee a 09:00.", vbInformation
End Sub

276. Generer un identifiant unique (GUID)

Function GenererGUID() As String
    Dim TypeLib As Object
    Set TypeLib = CreateObject("Scriptlet.TypeLib")
    GenererGUID = Mid(TypeLib.Guid, 2, 36)
End Function


Sub Macro276_InsererGUID()
    ActiveCell.Value = GenererGUID()
End Sub

277. Verifier si une valeur est un nombre

Sub Macro277_EstNombre()
    Dim val As String
    val = InputBox("Entrez une valeur :")
    If IsNumeric(val) Then
        MsgBox "'" & val & "' est un nombre.", vbInformation
    Else
        MsgBox "'" & val & "' n'est pas un nombre.", vbExclamation
    End If
End Sub

278. Verifier si une date est valide

Sub Macro278_DateValide()
    Dim val As String
    val = InputBox("Entrez une date (jj/mm/aaaa) :")
    If IsDate(val) Then
        MsgBox "Date valide : " & CDate(val), vbInformation
    Else
        MsgBox "Date invalide !", vbExclamation
    End If
End Sub

279. Afficher les proprietes du classeur

Sub Macro279_ProprietesClasseur()
    With ActiveWorkbook
        MsgBox "Nom : " & .Name & Chr(10) & _
               "Auteur : " & .Author & Chr(10) & _
               "Feuilles : " & .Sheets.Count, _
               vbInformation, "Proprietes"
    End With
End Sub

280. Lancer Notepad

Sub Macro280_LancerNotepad()
    Shell "notepad.exe", vbNormalFocus
End Sub

281. Interagir avec Word (creer un document)

Sub Macro281_CreerDocWord()
    Dim wdApp As Object
    On Error GoTo ErrWord
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Dim doc As Object
    Set doc = wdApp.Documents.Add
    doc.Content.Text = "Document cree depuis Excel VBA - " & Now
    Exit Sub
ErrWord:
    MsgBox "Microsoft Word n'est pas disponible.", vbExclamation
End Sub

282. Interagir avec PowerPoint (creer une presentation)

Sub Macro282_CreerPPT()
    Dim ppApp As Object
    On Error GoTo ErrPPT
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    ppApp.Presentations.Add
    Exit Sub
ErrPPT:
    MsgBox "PowerPoint n'est pas disponible.", vbExclamation
End Sub

283. Copier la mise en forme d'une cellule vers toute une colonne

Sub Macro283_CopierMEF()
    Dim Source As Range
    Set Source = ActiveCell
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, Source.Column).End(xlUp).Row
    Source.Copy
    Range(Cells(1, Source.Column), Cells(DerLigne, Source.Column)).PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End Sub

284. Generer un rapport automatique

Sub Macro284_RapportAuto()
    Dim shRap As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Rapport").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set shRap = Sheets.Add
    shRap.Name = "Rapport"
    With shRap
        .Range("A1").Value = "RAPPORT AUTOMATIQUE"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Size = 16
        .Range("A2").Value = "Genere le : " & Now
        .Range("A3").Value = "Classeur : " & ActiveWorkbook.Name
        .Range("A4").Value = "Nombre de feuilles : " & Sheets.Count
    End With
    MsgBox "Rapport genere.", vbInformation
End Sub

285. Numeroter les lignes automatiquement

Sub Macro285_NumeroterLignes()
    Dim DerLigne As Long
    DerLigne = Cells(Rows.Count, 2).End(xlUp).Row
    Dim i As Long
    For i = 1 To DerLigne
        Cells(i, 1).Value = i
    Next i
End Sub

286. Generer une table HTML depuis les donnees de la feuille

Sub Macro286_GenererHTML()
    Dim HTML As String
    Dim DerLigne As Long, DerCol As Long
    DerLigne = Cells(Rows.Count, 1).End(xlUp).Row
    DerCol = Cells(1, Columns.Count).End(xlToLeft).Column
    HTML = "<table border='1'>" & Chr(10)
    Dim r As Long, c As Long
    For r = 1 To DerLigne
        HTML = HTML & "<tr>" & Chr(10)
        For c = 1 To DerCol
            If r = 1 Then
                HTML = HTML & "<th>" & Cells(r, c).Value & "</th>"
            Else
                HTML = HTML & "<td>" & Cells(r, c).Value & "</td>"
            End If
        Next c
        HTML = HTML & "</tr>" & Chr(10)
    Next r
    HTML = HTML & "</table>"
    Dim Chemin As String
    Chemin = Environ("USERPROFILE") & "\Desktop\tableau.html"
    Dim num As Integer
    num = FreeFile
    Open Chemin For Output As #num
    Print #num, HTML
    Close #num
    MsgBox "HTML genere : " & Chemin, vbInformation
End Sub

287. Comparer deux colonnes et extraire les differences

Sub Macro287_DiffColonnes()
    Dim DerLigne As Long
    DerLigne = WorksheetFunction.Max( _
        Cells(Rows.Count, 1).End(xlUp).Row, _
        Cells(Rows.Count, 2).End(xlUp).Row)
    Dim i As Long
    Dim cpt As Long
    cpt = 1
    For i = 1 To DerLigne
        If Cells(i, 1).Value <> Cells(i, 2).Value Then
            Cells(cpt, 4).Value = "Ligne " & i & " : '" & Cells(i, 1).Value & "' vs '" & Cells(i, 2).Value & "'"
            cpt = cpt + 1
        End If
    Next i
    MsgBox cpt - 1 & " difference(s) trouvee(s) en colonne D.", vbInformation
End Sub

288. Creer une macro de bienvenue personnalisee

Sub Macro288_Bienvenue()
    Dim Heure As Integer
    Heure = Hour(Now)
    Dim Salut As String
    Select Case Heure
        Case 5 To 11 : Salut = "Bonjour"
        Case 12 To 17 : Salut = "Bon apres-midi"
        Case 18 To 21 : Salut = "Bonsoir"
        Case Else : Salut = "Bonne nuit"
    End Select
    MsgBox Salut & ", " & Application.UserName & " !" & Chr(10) & _
        "Il est " & Format(Now, "hh:mm") & " le " & Format(Date, "dd/mm/yyyy"), _
        vbInformation, "Bienvenue"
End Sub

289. Creer un journal des modifications

Sub Macro289_JournalModifications()
    Dim shLog As Worksheet
    On Error Resume Next
    Set shLog = Sheets("Journal")
    On Error GoTo 0
    If shLog Is Nothing Then
        Set shLog = Sheets.Add
        shLog.Name = "Journal"
        shLog.Cells(1, 1).Value = "Date/Heure"
        shLog.Cells(1, 2).Value = "Utilisateur"
        shLog.Cells(1, 3).Value = "Action"
    End If
    Dim DerLigne As Long
    DerLigne = shLog.Cells(shLog.Rows.Count, 1).End(xlUp).Row + 1
    shLog.Cells(DerLigne, 1).Value = Now
    shLog.Cells(DerLigne, 2).Value = Application.UserName
    shLog.Cells(DerLigne, 3).Value = InputBox("Decrivez l'action effectuee :")
    MsgBox "Action journalisee.", vbInformation
End Sub

290. Creer un calendrier mensuel

Sub Macro290_Calendrier()
    Dim Annee As Integer, Mois As Integer
    Annee = InputBox("Annee :")
    Mois = InputBox("Mois (1-12) :")
    Dim Jours(1 To 7) As String
    Jours(1) = "Dim" : Jours(2) = "Lun" : Jours(3) = "Mar"
    Jours(4) = "Mer" : Jours(5) = "Jeu" : Jours(6) = "Ven" : Jours(7) = "Sam"
    Dim i As Integer
    For i = 1 To 7
        Cells(1, i).Value = Jours(i)
        Cells(1, i).Font.Bold = True
    Next i
    Dim jourCourant As Date
    jourCourant = DateSerial(Annee, Mois, 1)
    Dim ligne As Integer, col As Integer
    ligne = 2
    col = Weekday(jourCourant)
    Do While Month(jourCourant) = Mois
        Cells(ligne, col).Value = Day(jourCourant)
        col = col + 1
        If col > 7 Then
            col = 1
            ligne = ligne + 1
        End If
        jourCourant = jourCourant + 1
    Loop
    MsgBox "Calendrier cree !", vbInformation
End Sub

291. Generer un numero de serie unique

Sub Macro291_NumeroSerie()
    ActiveCell.Value = "SN" & Format(Now, "yyyymmddhhmmss")
End Sub

292. Utiliser le presse-papiers Windows

Sub Macro292_PressePapiers()
    Dim obj As Object
    On Error Resume Next
    Set obj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    If Err.Number = 0 Then
        obj.SetText "Texte copie depuis VBA !"
        obj.PutInClipboard
        MsgBox "Texte copie dans le presse-papiers.", vbInformation
    Else
        MsgBox "Presse-papiers non disponible.", vbExclamation
    End If
    On Error GoTo 0
End Sub

293. Proteger toutes les feuilles avec le meme mot de passe

Sub Macro293_ProtegerToutesFeuilles()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe pour proteger toutes les feuilles :")
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        sh.Protect Password:=Mdp
    Next sh
    MsgBox "Toutes les feuilles ont ete protegees.", vbInformation
End Sub

294. Deproteger toutes les feuilles

Sub Macro294_DeprotegerToutesFeuilles()
    Dim Mdp As String
    Mdp = InputBox("Mot de passe :")
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        On Error Resume Next
        sh.Unprotect Password:=Mdp
        On Error GoTo 0
    Next sh
    MsgBox "Toutes les feuilles ont ete deprotegees.", vbInformation
End Sub

295. Convertir tous les nombres en texte dans la selection

Sub Macro295_NombresEnTexte()
    Dim c As Range
    For Each c In Selection
        If IsNumeric(c.Value) Then
            c.Value = "'" & CStr(c.Value)
        End If
    Next c
End Sub

296. Mettre en majuscule la 1ere lettre de chaque phrase

Sub Macro296_MajusculePhrases()
    Dim c As Range
    Dim txt As String
    For Each c In Selection
        If Not IsEmpty(c) Then
            txt = LCase(CStr(c.Value))
            Mid(txt, 1, 1) = UCase(Left(txt, 1))
            c.Value = txt
        End If
    Next c
End Sub

297. Creer des cartes de couleurs dans la feuille

Sub Macro297_CartesCouleurs()
    Dim Couleurs(1 To 10) As Long
    Couleurs(1) = RGB(255, 0, 0) : Couleurs(2) = RGB(0, 255, 0)
    Couleurs(3) = RGB(0, 0, 255) : Couleurs(4) = RGB(255, 255, 0)
    Couleurs(5) = RGB(255, 0, 255) : Couleurs(6) = RGB(0, 255, 255)
    Couleurs(7) = RGB(255, 128, 0) : Couleurs(8) = RGB(128, 0, 128)
    Couleurs(9) = RGB(0, 128, 0) : Couleurs(10) = RGB(128, 128, 128)
    Dim i As Integer
    For i = 1 To 10
        Cells(i, 1).Interior.Color = Couleurs(i)
        Cells(i, 1).Value = "Couleur " & i
    Next i
End Sub

298. Generer une serie de dates de travail (5 jours/semaine)

Sub Macro298_SerieDatesTravail()
    Dim DateDebut As Date
    DateDebut = InputBox("Date de debut (jj/mm/aaaa) :")
    Dim N As Integer
    N = InputBox("Nombre de jours ouvres :")
    Dim i As Long
    Dim cpt As Integer
    cpt = 0
    Dim d As Date
    d = DateDebut
    Do While cpt < N
        If Weekday(d) <> vbSunday And Weekday(d) <> vbSaturday Then
            cpt = cpt + 1
            Cells(cpt, 1).Value = d
            Cells(cpt, 1).NumberFormat = "dd/mm/yyyy"
        End If
        d = d + 1
    Loop
End Sub

299. Effacer le contenu de toutes les cellules de couleur specifique

Sub Macro299_EffacerCellulesCouleur()
    Dim Couleur As Long
    Couleur = RGB(255, 255, 0) ' Jaune - modifiable
    Dim c As Range
    For Each c In ActiveSheet.UsedRange
        If c.Interior.Color = Couleur Then
            c.ClearContents
        End If
    Next c
    MsgBox "Cellules jaunes effacees.", vbInformation
End Sub

300. Macro Maitre : Menu principal de toutes les categories

Sub Macro300_MenuPrincipal()
    Dim Choix As String
    Choix = InputBox("=== MENU PRINCIPAL - 300 MACROS VBA ===" & Chr(10) & Chr(10) & _
        "1  - Classeurs & Feuilles (1-40)" & Chr(10) & _
        "2  - Cellules & Plages (41-90)" & Chr(10) & _
        "3  - Mise en Forme (91-130)" & Chr(10) & _
        "4  - Donnees & Tri (131-170)" & Chr(10) & _
        "5  - Formules & Calculs (171-200)" & Chr(10) & _
        "6  - Graphiques (201-220)" & Chr(10) & _
        "7  - Boites de Dialogue (221-240)" & Chr(10) & _
        "8  - Fichiers & Dossiers (241-260)" & Chr(10) & _
        "9  - Impression (261-270)" & Chr(10) & _
        "10 - Automation & Divers (271-300)" & Chr(10) & Chr(10) & _
        "Entrez un numero de categorie :", "Menu")
    Select Case Choix
        Case "1" : MsgBox "Categorie 1 : Macros 001 a 040 - Classeurs & Feuilles", vbInformation
        Case "2" : MsgBox "Categorie 2 : Macros 041 a 090 - Cellules & Plages", vbInformation
        Case "3" : MsgBox "Categorie 3 : Macros 091 a 130 - Mise en Forme", vbInformation
        Case "4" : MsgBox "Categorie 4 : Macros 131 a 170 - Donnees & Tri", vbInformation
        Case "5" : MsgBox "Categorie 5 : Macros 171 a 200 - Formules & Calculs", vbInformation
        Case "6" : MsgBox "Categorie 6 : Macros 201 a 220 - Graphiques", vbInformation
        Case "7" : MsgBox "Categorie 7 : Macros 221 a 240 - Boites de Dialogue", vbInformation
        Case "8" : MsgBox "Categorie 8 : Macros 241 a 260 - Fichiers & Dossiers", vbInformation
        Case "9" : MsgBox "Categorie 9 : Macros 261 a 270 - Impression", vbInformation
        Case "10" : MsgBox "Categorie 10 : Macros 271 a 300 - Automation & Divers", vbInformation
        Case Else : If Choix <> "" Then MsgBox "Choix invalide.", vbExclamation
    End Select
End Sub


' ============================================================
' FIN DES 300 MACROS VBA EXCEL
' ============================================================
' COMMENT UTILISER CE FICHIER :

1. Ouvrez Excel et appuyez sur Alt+F11 (editeur VBA)

2. Allez dans Insertion > Module

3. Copiez-collez le contenu de ce fichier .bas dans le module

'    (ou allez dans Fichier > Importer le fichier et selectionnez ce .bas)

4. Appuyez sur Alt+F8 pour voir la liste des macros

5. Selectionnez une macro et cliquez sur "Executer"

' ============================================================