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
'================================================
'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
[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]
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
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
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
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
Sub faitpéterprotectionfeuille()
ActiveSheet.Protect vbNullString, , True, , , , , , , , , , , , , True
ActiveSheet.Unprotect vbNullString
End Sub
pour les feuilles protégées j'utilise ceci (rarement car pour mes classeurs je mets des protections sans mot de passe)
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