Top 50 des macros préférées des xldiens

Staple1600

XLDnaute Barbatruc
Suite au conseil de Darnel

J'ouvre ce fil pour que chacun l'alimente
de sa macro ses macros préférées
(qu'il utilise dans un cadre professionnel ou ludique)

Voila qu'en pensez-vous?


Ps: lors de mes pérégrinations ce matin sur le web j'ai trouvé cela:
(Pour les anglophone, mais c'est très intéressant)
(enfin moi ça m'a intéressé)
Ce lien n'existe plus
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

macro 1/50

macro 1
Créer 12 feuilles mensuelles dans un classeur

Code:
Sub Mois12F()
'issue de VBA pour Excel (ISBN: 2-7429-6110-0)
Dim i s Integer
For i=1 to 12
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(30*i,"mmmm")
Next
For i= 1 To Worksheets.Count -12
SendKeys "{enter}
Sheets(1).Delete
Next
End sub

MACRO A TESTER SUR UN CLASSEUR VIERGE
(ne contenant aucune données)
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

Macro 2/50

Sub Wish_You_Were_Here()
dgs=MsgBox "Aurais-je eu une mauvaise?",vbYesNo,"Question"
if dgs <> vbYes Then Exit sub
MsgBox "C'est qu'il semblerait au vue des réponses obtenues..."
End Sub

Au plaisir de vous lire
 

Hervé

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

bonjour staple, le forum


un code que j'utilise souvent pour retrouver les index des colorindex :

Code:
Dim i As Byte

With Sheets.Add
    For i = 1 To 56
        .Cells(i, 1).Interior.ColorIndex = i
        .Cells(i, 2) = i
    Next i
End With

salut
 

Jam

XLDnaute Accro
Re : Top 50 des macros préférées des xldiens

Utile lorsqu'on a oublié le MdP d'une feuille:

Code:
'================================================
'Sub qui permets de faire sauter la protection de
'n'importe quelle feuille (auteur inconnu)
'================================================
Sub BreakPasswordSheet()

Dim i As Integer, j As Integer, k As Integer, l As Integer, M As Integer, N As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer

On Error Resume Next
     
For i = 65 To 66
    For j = 65 To 66
        For k = 65 To 66
            For l = 65 To 66
                For M = 65 To 66
                    For i1 = 65 To 66
                        For i2 = 65 To 66
                            For i3 = 65 To 66
                                For i4 = 65 To 66
                                    For i5 = 65 To 66
                                        For i6 = 65 To 66
                                            For N = 32 To 126
                                                ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(M) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(N)
                                                If ActiveSheet.ProtectContents = False Then
                                                    MsgBox "One useble password is " & Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(M) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(N)
                                                    Exit Sub
                                                End If
                                            Next
                                        Next
                                    Next
                                Next
                            Next
                        Next
                    Next
                Next
            Next
        Next
    Next
Next

End Sub

A+
 

nat54

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

Bonjour,

Moi c'est enlever les doublons d'une liste :d

Code:
[FONT=Arial]Sub ENLEVER_DOUBLONS()[/FONT]
[FONT=Arial]ListeValUniques Range("A2:A5000"), Range("E1")   [/FONT][COLOR=teal][FONT=Arial]‘ on met la liste en colonne 1, la liste épurée se colle en colonne E[/FONT][/COLOR][FONT=Arial][/FONT]
[FONT=Arial]End Sub[/FONT]
[FONT=Arial] [/FONT]
[FONT=Arial]Sub ListeValUniques(PlageSrc As Range, CellDest As Range)[/FONT]
[COLOR=teal][FONT=Arial]'Extrait les valeurs uniques d'une colonne et les renvoie[/FONT][/COLOR]
[COLOR=teal][FONT=Arial]'dans une autre, à partir de CellDest[/FONT][/COLOR][FONT=Arial][/FONT]
[FONT=Arial]Dim Arr1, Elt, Arr2(), Coll As New Collection[/FONT]
[FONT=Arial] [/FONT]
[FONT=Arial]If PlageSrc.Columns.Count > 1 Then Exit Sub[/FONT]
[FONT=Arial]Arr1 = PlageSrc.Value[/FONT]
[FONT=Arial] [/FONT]
[FONT=Arial]For Each Elt In Arr1[/FONT]
[FONT=Arial]On Error Resume Next[/FONT]
[FONT=Arial]Coll.Add Elt, CStr(Elt)[/FONT]
[FONT=Arial]If Err.Number = 0 Then[/FONT]
[FONT=Arial]ReDim Preserve Arr2(1 To Coll.Count)[/FONT]
[FONT=Arial]Arr2(Coll.Count) = Elt[/FONT]
[FONT=Arial]End If[/FONT]
[FONT=Arial]On Error GoTo 0[/FONT]
[FONT=Arial]Next[/FONT]
[FONT=Arial] [/FONT]
[FONT=Arial]CellDest.Resize(Coll.Count).Value = _[/FONT]
[FONT=Arial]Application.Transpose(Arr2)[/FONT]
[FONT=Arial] [/FONT]
[FONT=Arial]End Sub[/FONT]
 

Staple1600

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

Bonjour à tous


Une macro parfois bien utile
Code:
Sub TRADUCTEUR_FORMULES()
Dim FORM_A_TRAD As Range, EN_FRANCAIS$, EN_ANGLAIS$
On Error Resume Next
Set FORM_A_TRAD = Application.InputBox("Choisir la cellule contenant la formule", , , , , , , 8)
On Error GoTo 0
If FORM_A_TRAD Is Nothing Then
    MsgBox "Annulation"
    Exit Sub
End If
If Not FORM_A_TRAD.HasFormula Then
MsgBox "Cellule sélectionnée sans formule!", vbCritical, "ERREUR"
Exit Sub
End If
EN_FRANCAIS = FORM_A_TRAD.FormulaLocal
EN_ANGLAIS = FORM_A_TRAD.Formula
MsgBox "Formule en francais: " & _
EN_FRANCAIS & vbCrLf & _
"Equivalent anglais: " & EN_ANGLAIS, vbInformation, "TRADUCTEUR FORMULE"
End Sub
 
Dernière édition:
M

Mytå

Guest
Re : Top 50 des macros préférées des xldiens

Salut le Forum

Un fichier regroupant des codes avec la méthode Intersect

Les exemples ont été faits par _Thierry

Mytå
 

Pièces jointes

  • Intersect.zip
    685 bytes · Affichages: 310
  • Intersect.zip
    685 bytes · Affichages: 309
  • Intersect.zip
    685 bytes · Affichages: 305

STephane

XLDnaute Occasionnel
Re : Top 50 des macros préférées des xldiens

Histoire de relancer le fil :

Ma préférée, elle contient que 2 lignes de code mais beaucoup de commentaires ;-)

Code:
Private Function QAB_MsgboxLtd(Msg, Optional scds, Optional Title)
'
'=======================================================================
'= Procedure    : MsgboxLtd                                            =
'= Type         : Function                                             =
'=                                                                     =
'= Purpose      : displays a temporary dialogbox                       =
'=                                                                     =
'= Parameters   : msg - variant - contents of the message to display.  =
'=                scds - variant - display duration                    =
'=                title - variant - dialogbox's optional title         =
'=                                                                     =
'= Returns      : nothing                                              =
'=                                                                     =
'= Version:  Date:         Developer:      Action:                     =
'=---------|---------------|---------------|-------------------------- =
'=  1.0.0  | Long time Ago |   STéphane    | Created                   =
'=  1.0.0  | 09/02/2012    |   STéphane    | Opensourced               =
'=======================================================================
'
' La fonction affiche une boîte de dialogue temporaire.
' Elle doit être appelée en spécifiant au moins un message et un nombre de seconde ;
' le titre de la boîte de dialogue peut être spécifié, il prend par défaut la valeur "Alerte".
'
If IsMissing(Title) Then Title = "Alerte"
CreateObject("WScript.Shell").Popup Msg, IIf(IsMissing(scds), 1, scds), Title
End Function

J'aime bien celle là, faite la semaine passée, appelées dans diverses macros pour contrôler l'environnement.
Code:
Function GreenLight(Optional bRange As Boolean, Optional bWorksheet As Boolean, Optional bButThis As Boolean)
'' by STéphane
Dim bFlag As Boolean
If bRange = True Then bFlag = (TypeName(Selection) = "Range")
If bWorksheet = True Then bFlag = (ActiveSheet.Type = xlWorksheet)
If bButThis = True Then bFlag = (ActiveWorkbook.FullName <> ThisWorkbook.FullName)
QAB_GreenLight = bFlag
End Function
'.. if Greenlight(1)=false then exit sub
 
Dernière édition:

GeoTrouvePas

XLDnaute Impliqué
Re : Top 50 des macros préférées des xldiens

Bonjour,

La création de ce fil est une excellent initiative ! Merci Staple !

Personnellement c'est une macro complémentaire (à repasser en .xla) que je souhaiterai partager. Je m'en sers 1 000 fois par jour pour protéger (et déprotéger), masquer le quadrillage, les onglets et les en - têtes sur la totalité d'un classeur. Le Mdp est une constante déclarée dans le module A0_Déclarations. Les macros se lancent à partir d'un menu personnalisé.

Edit :
Attention : l'ouverture de ce fichier crée un menu personnalisé dans Excel. Ce menu est supprimé automatiquement lors de la fermeture
 

Pièces jointes

  • Perso3.xls
    37 KB · Affichages: 197
  • Perso3.xls
    37 KB · Affichages: 222
  • Perso3.xls
    37 KB · Affichages: 222
Dernière édition:

Dugenou

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

Bonjour à tous,
Bravo staple pour l'initiative !
Ma préférée permet de nettoyer les valeurs qui n'existent plus dans tous les tcd d'un classeur.
Récupérée à partir de liens sur ce site. Evidemment je n'ai pas noté la source et je m'en excuse !

Code:
Sub nettoyageTCD()
'Sub DeleteMissingItems2002All()
'prevents unused items in non-OLAP PivotTables

'in Excel 2002 and later versions
'If unused items already exist,
  'run this macro then refresh the table
Dim pt As PivotTable
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
  For Each pt In ws.PivotTables
    pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
    pt.PivotCache.Refresh
  Next pt
Next ws

End Sub
 

Dugenou

XLDnaute Barbatruc
Re : Top 50 des macros préférées des xldiens

Re,
pour les feuilles protégées j'utilise ceci (rarement car pour mes classeurs je mets des protections sans mot de passe)

Code:
Sub faitpéterprotectionfeuille()
ActiveSheet.Protect vbNullString, , True, , , , , , , , , , , , , True
ActiveSheet.Unprotect vbNullString
End Sub
 

GeoTrouvePas

XLDnaute Impliqué
Re : Top 50 des macros préférées des xldiens

pour les feuilles protégées j'utilise ceci (rarement car pour mes classeurs je mets des protections sans mot de passe)

Bonjour Dugenou.
Je ne suis pas un grand partisan des mdp mais à force que les gens fasse n'importe quoi et râlent parce que le fichier ne marche plus, j'y ai été contraint.

Au départ j'étais parti d'un code similaire au tiens et je l'ai amélioré / complété au fur et à mesure de son utilisation.
Ainsi il ne protège pas que la feuille active mais boucle sur tout le classeur (et te ramène sur la feuille de départ à la fin de la boucle). Avant de protéger la feuille, il sélectionne une cellule (car la macro peut planter dans le cas où un objet est sélectionné sur une feuille).

Pour ceux qui ne peuvent / veulent ppas télécharger la PJ, voici le code :

Code:
Public Sub Deverrouiller_Fichier()
    FeuilleActive = ActiveSheet.Name
    Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:=Key_Perso
    For i = 1 To ActiveWorkbook.Sheets.Count
        With ActiveWorkbook.Sheets(i)
            .Unprotect Password:=Key_Perso
            .Visible = True
            .Select
            .Cells(1, 1).Select
            With ActiveWindow
                .DisplayGridlines = True
                .DisplayHeadings = True
                .DisplayWorkbookTabs = True
            End With
        End With
    Next
    ActiveWorkbook.Sheets(FeuilleActive).Select
    Application.ScreenUpdating = True
End Sub
Public Sub Verrouiller_Fichier()
    Dim Entetes As Boolean
    Dim Quadrillage As Boolean
    Dim Onglets As Boolean
    Dim FeuilleActive As String
    FeuilleActive = ActiveSheet.Name
    Application.ScreenUpdating = False
    If MsgBox("Masquer le quadrillage ?", vbYesNo, "") = vbYes Then Quadrillage = False Else Quadrillage = True
    If MsgBox("Masquer les en - têtes ?", vbYesNo, "") = vbYes Then Entetes = False Else Entetes = True
    If MsgBox("Masquer les onglets ?", vbYesNo, "") = vbYes Then Onglets = False Else Onglets = True
    ActiveWorkbook.Unprotect Password:=Key_Perso
    For i = 1 To ActiveWorkbook.Sheets.Count
        ActiveWorkbook.Sheets(i).Select
        ActiveWorkbook.Sheets(i).Cells(1, 1).Select
        ActiveSheet.Unprotect Password:=Key_Perso
        With ActiveWindow
            .DisplayGridlines = Quadrillage
            .DisplayHeadings = Entetes
            .DisplayWorkbookTabs = Onglets
        End With
        ActiveWorkbook.Sheets(i).Protect Password:=Key_Perso
    Next
    ActiveWorkbook.Protect Password:=Key_Perso
    ActiveWorkbook.Sheets(FeuilleActive).Select
    Application.ScreenUpdating = True
End Sub
 

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG