VBA - Book of Knowledge

Pour activer l'Auto-Completion, au moment de l'écriture des premiers caractères de l'objet, appuyez sur les touches Ctrl+Espace simultanément.

*** Les fonctions d'Optimisation ***

blocage/déblocage des evenements
--> Application.EnableEvents = False/True
Activ/Désactivation du rafraîchissement de l'écran
--> Application.ScreenUpdating = False/True
choix de l'option par défaut pour toutes question
--> Application.DisplayAlerts = False/True

Calculs manuel : Application.Calculation = xlCalculationManual
Calculs automatique : Application.Calculation = xlCalculationAutomatic
Calculs d'un range : Range("F2:F8").Calculate

-----------------------
LES VARIABLES
-----------------------

Afin de renforcer la sécurité du code, et forcer la necessité de déclarer chaque variable, on peut rajouter en début de Module : Option Explicit

Portée des variables
Sur le projet : en début de module : Public Dim VarAPortéeGlobale as string
Sur le module : en début de module : Private Dim VarAPortéeModule as string
Sur la fonction : en début de fonction/procédure Dim VarAPortéeLocale as string

Variables : Dim ExempleVariable as string
Constantes : Const ExConstante = 0

Types

Définition d'un nouveau Type :
Type Texemple
sheet As Sheets
Cat As String
Cell As Range
End Type
Dim Exemple as Texemple '(Exemple.Sheet, Exemple.Cat, Exemple.Cell)

* Les tableaux (ARRAYS ) *
1 - Static var arrays
Dim VArray(1 to 12) as string --> (vArr(1)="Janv : vArr(3)="Mars":..: vArr(12)="Déc")
Dim Tableau (10) as integer --> (tableau de 10 entiers dont le premier entier est Tableau(0))
Dim VArray(1 to 10, 1 to 31) as integer --> (Varray(1,2) = 43)

2 - Static const arrays
ListeJours = Array("Lundi","Mardi", .... ,"Vendredi","Samedi")
valeur minimale des index du tableau : LBound(ListeJours) = 0 valeur maximale des index du tableau : UBound(ListeJours) = 6

3 - Dynamic var arrrays
Dim Varray as Variant
ReDim MyNames(1 to 10)
Erase Varray()

Lbound(Varray) ==> 1 (index inferieur)
UBound(Varray) ==> 10 (index supérieur)


-------------------------------------------------
Les routines (procédures ou fonctions)
-------------------------------------------------

Portées des routines:

Public : elle sera accessible à toutes les autres routines dans tous les autres modules de tous les projets actifs (défaut).
Private : si elle sera seulement accessible à d'autres procédures dans le même module.
Static : Les valeurs des variables déclarées dans cette Function sont préservées entre les appels VBA d'Excel.

*** Procédures ***

Une Procédure est une suite d'instructions qui ne retourne pas de valeur

Sub ExempleProcédureInit(arg1 as integer ,arg2 as string, optional arg3 as string)
if ismissing(arg3) then action1 else action2
End Sub

Le test de présence d'une variable lors d'un appel à une proce se fait avec l'instruction IsMissing.
*** Fonctions ***

Une fonction est une suite d'instructions qui retourne une valeur.

Function exemple_de_fontion(arg1 as integer ,arg2 as string) as boolean
End Function

-------------------------
LES CONSTANTES
-------------------------
bleufonce = 47: mauve=39: vert=35: jaune=19: orange=40: rouge0=22: rouge1=3: violet=39: bleu0=24: bleu1=17: bleu2=47: blanc=2: gris20=15: gris40=48: gris60=16: gris80=56: noir=1: rose=38: marron=53: vertfonce=14

-------------
LE CODE
-------------

* Condition *

if test then
action
Elseif test2
action2
Else
action3
End if

If test Then_
action1 Else action2

If test Then action1

Valeur = IIF(test;Valeur1;Valeur2)

Select case valeur
case valeur1: action1
case valeur2: action2
End select

* Cellules *

IsNumeric(), IsDate(), IsEmpty()
cells(1,3) = range("a3") = [a3]
couleur_de_la_police_de_caractère = cells(x,y).Font.ColorIndex
gras = cells(x,y).Font.bold = True
italic = cells(x,y).Font.italic = True
nom de la police = cells(x,y).Font.name = Arial
taille de la police = cells(x,y).Font.size = 12
underline = cells(x,y).Font.underline = True
couleur_de_fond = cells(x,y).Interior.ColorIndex

liste des index :

style_de_ligne = cells(x,y).Borders(bordure).LineStyle
Style_de_ligne = { xlNone xlContinuous }
taille_bordure = cells(x,y).Borders(bordure).Weight
Taille_bordure = { xlThin xlmedium xlThick}
couleur des bordures = cells(x,y).Borders.ColorIndex
couleur de bordure = cells(x,y).Borders(bordure).ColorIndex
Bordure = { xlInsideVertical xlDiagonalDown xlEdgeTop xlEdgeLeft xlEdgeRight xlDiagonalUp xlEdgeBottom }
Valeur de la cellule = cells(x,y).value
Cellule avant chgt de cellule = Target
n°ligne = Cells(x,y).row
n°colonne = Cells(x,y).column
Supprimer la ligne de la case D3 --> range("D3").Delete Shift:=xlUp
Supprimer la ligne de la case D3 --> range("D3").EntireRow.Delete
Ajouter une ligne --> Rows("10:10").Insert Shift:=xlDown
Rechercher un cellule --> Set FoundCell = range("D3:D7").Find(valtoseek, LookIn:=xlValues) : FoundLine = IIf (Cellule Is Nothing,0, FoundCell.row)
Fixer la taille de la ligne --> Rows("10:10").RowHeight = 12.75
Selection.UnMerge
Set exemple_objet_cellule = Cells(x,y).offset(x,y)
Set sheet1 = Sheets("Feuille n°1") : Set sheet2 = Sheets(2)
Effacer le contenu des cellules --> [A1:A10].ClearContents
Selectionner plusieurs lignes --> sheet.Rows("25:43,52:58").Select
Selectionner plusieurs colonnes --> sheet.Columns("A:B","D:H").Select
Première ligne de [A1:A10] --> [A1:A10].CurrentRegion.Rows(1)
Dernière ligne de [A1:A10] --> [A1:A10].CurrentRegion.Rows( [A1:A10].CurrentRegion.Rows.Count)
Cellules vides de [A1:A10] --> [A1:A10].SpecialCells(xlCellTypeBlanks)
Cellules num de [A1:A10] --> [A1:A10].SpecialCells(xlCellTypeConstants, 1) { 1 = num 2 = str 3 = str ou num }
Cells commentées de [A1:A10] --> [A1:A10].SpecialCells(xlCellTypeComments)
Cellule non vide la plus à droite de [A1:A10] --> [A1:A10].End(xlToRight)
{ xlDown xlToRight xlToLeft xlUp }
masquer des lignes --> Range("A1").EntireRow.Hidden = True
compter le nb de lignes dans une selection : Selection.rows.Count
compter le nb de colonnes dans une selection : Selection.Columns.Count

* Nombres *

retourne la val abs Abs(-9) = 9
retourne le signe Sgn(-9) = -1 {-1 0 1 }
arrondi a l'ent inf Int(13,9) = 13 {Int(-13,1) = -14}
Partie entière Fix(13,9) = 13 {Fix(-13,1) = -13}
nb aléat entre [0 - 1[ = Randomize pour initialiser puis Rdn
Modulo 32 Mod 10 = 2
Puissance 2^3 = 8
racine carré SQR(4) = 2
Division complète 10/3 = 3,33333
Division entière 10\3 = 3

* Logique *

AV-BV AF-BV AV-BF AF-BF
------------------------------------------------------------------
not a F V F V
a and b V F F F
a or b V V V F
a Xor b F V V F

* Chaines de caractères *


Transfo ASCII en caractère : Chr(34)
Transfo caractère en code Ascii : Acs("A")
Transfo nombre en strings
Transfo strings en nombres

- Constantes de chaines

String(20,x) = "xxxxxxxxxxxxxxxxxxxx"
space(20) = " "
monTab = split("c/de/fgt","/") (montab(0) = "c" , montab(1) = "de" , montab(2) = "fgt" )
Trim(" toto ") = "toto" (existent aussi LTrim & RTrim)
strNew = Replace(strOld,",",".") (remplacer les virgules par des points)
Len("toto") = 4
InStr("toto","o") = 2
Lcase("TOTO") = toto
UCase("toto") = TOTO
Left("Fabrice",3) = "fab"
Right("Fabrice",3) = "ice"
mid("Fabrice",5,2) = "ic"

* Tris *

Trier des cellules
--> range("D1:D6").Sort Key1:=Range(myrange), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal
--> Selection.Sort Key1:=Range(Cells(startline, Column_selected), Cells(Endline,
Column_selected)), Order1:=xlAscending, Key2:=Range(Cells(startline,
ConsoCat_status.column), Cells(Endline, ConsoCat_status.column)), Order2:=xlAscending,
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortNormal,
DataOption3:=xlSortNormal

* Boucles *

for x = 10 to 0 Step -1 action Next
for each cellule in selected_range action Next
x = 0 Do action loop Until test
x = 0 While test action Wend

* Formats & dates *

Format(Date, "yy/mmmm/dd")
n ieme jour de l'année = Format(Date, "y")
Now , time, date
Nombre de millisecondes écoulées depuis le démarrage du système : GetTickCount
nb de secondes depuis minuit = timmer
Année = year(date)
n° du Mois = month(date)
nom du Mois = monthname(date)
Jour = day(date)
Heure = heure(date)
Minute = minute(date)
Seconde = seconde(date)
num de série de la date du jour = aujourdhui()
num de série de la date et de l'heure = maintenant()
num de série du dern jr du mois = FIN.MOIS(Date_départ;Mois)
nb de jrs ouvrés entre 2 dates = NB.JOURS.OUVRES(Date1;Date1;liste_Jours_fériés) :
jour de la semaine (de 1 à 7) = JOURSEM(Numéro_de_série;Type_retour) :
Nombre de jours dans le mois = JOUR(DATE(ANNEE(D);MOIS(D)+1;0))

Conv : CBool(), CByte(), CCur(), CDate(), CDbl(), CDec(), CInt(), CLng(), Csng(), Cstr(), Cvar()

* Objets *

Set objExcel = CreateObject("Excel.Application")
Sheets("nom_de_la_feuille").Unprotect
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlUnlockedCells
For Each feuille In Worksheets --- --- Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=Sheet & "A1", TextToDisplay:=""
Sheets("#1").Unprotect
Sheets("#1").Copy After:=Sheets(Sheets.Count)
newsheetname = "#" & Sheets.Count - 2
Sheets("#1 (2)").name = newsheetname

* Fichiers *

Change l'attribut : SetAttr FichierUNC, attribut

- Liste des attributs

Utilise le lecteur D comme lecteur courant = ChDrive "D"
Assigne le chemin courant à une variable a a = CurDir
crée un dossier dans le dossier courrant = MkDir "mon_dossier"
supprime un dossier vide dans le dossier courant = RmDir "mon_dossier"
Détruit tous les fichiers .doc du dossier courant = Kill "*.doc"
Utilise "c:\temp" comme nouveau dossier courant = ChDir "c:\temp"

Ouvrir un fichier (en lect seul) : open "Fichier.txt" For Input As #1 {fichier n° 1)
Le lire : Do While Not EoF(1)
Line Input #1, Textline : Msgbox textline
loop
Fermer ce fichier Close #1

Ouvrir un fichier (ecriture) : open "Fichier.txt" For output As #1 {fichier n° 1)
ecrire dedans : liste = 0 : Do While liste < liste =" Liste">
Active une fenetre : Windows(nom_du_fichier).Activate

Sauvegarde un wkbook : ActiveWorkbook.SaveAs Filename:=nom_UNC_du_Fichier, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Fermeture d'une fenetre : ActiveWindow.Close
Quitter sans enregistrer:
Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Close savechanges:=False End Sub
Fermeture du classeur : wbExcel.Close
Fermeture de l'app Excel: appExcel.Quit
Désallocation mémoire : Set wsExcel = Nothing

--> Ouverture d'une feuille excel XLS ou csv
(les fichiers CSV sont des fichiers textes où une ligne du fichier correspond à une ligne de la feuille et les colonnes sont séparées par des ';') ,45, 4,10,23
Dim appExcel As Excel.Application 'Application Excel
Dim wbExcel As Excel.Workbook 'Classeur Excel
Dim wsExcel As Excel.Worksheet 'Feuille Excel
Set appExcel = CreateObject("Excel.Application") 'Ouverture de l'application
Set wbExcel = appExcel.Workbooks.Open(nom_UNC_du_fichier) 'Ouverture d'un fichier Excel
Set wsExcel = wbExcel.Worksheets(1) 'wsExcel correspond à la première feuille du fichier

--> Spécificité d'un fichier texte avec comme séparateur le ';' commençant à la deuxième ligne et au format Windows(ANSI)
Dim appExcel As Excel.Application 'Application Excel
Dim wbExcel As Excel.Workbook 'Classeur Excel
Dim wsExcel As Excel.Worksheet 'Feuille Excel
Set appExcel = CreateObject("Excel.Application")'Ouverture de l'application
Workbooks.OpenText Filename:= nom_UNC_du_fichier, Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True'Ouverture d'un fichier Excel
Set wbExcel=appExcel.ActiveWorkbook
Set wsExcel=wbExcel.ActiveSheet

* Impression *

Sheets(1).PageSetup.LeftFooter = "&Bcommentaire_de_gauche&B"
Sheets(1).PageSetup.CenterFooter = "&8Page &amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;P & of &N"
Sheets(1).PageSetup.RightFooter = "&8Last Saved : &B" & ActiveWorkbook.BuiltinDocumentProperties("Last save time")
ActiveSheet.PageSetup.PrintArea = "$B$2:$AH$9"
ActiveSheet.PrintOut Copies:=1, Collate:=True
Range("A1:D4").PrintOut


* Dialogues *

La fonction MsgBox affiche un message dans une boîte de dialogue, attend que l'utilisateur clique sur un bouton, puis renvoie un entier indiquant le bouton choisi par l'utilisateur.
reponse = MsgBox(prompt[,Options][,title][,helpfile, context])
reponse = MsgBox("Question à poser", vbYesNo + vbCritical + vbDefaultButton, "Titreboite")

Avec option = Type boutons + Style Icône + Bouton par défaut + Modalité de la boite de dialogue

- valeurs de la variable Type boutons -

- valeurs de la variable Style Icône -

- valeurs de la variable Bouton par défaut

- valeurs de la variable Modal

- valeurs possible de la réponse de la msgbox

La fonction InputBox affiche une invite dans une boîte de dialogue, attend que l'utilisateur tape du texte ou clique sur un bouton, puis renvoie le contenu de la zone de texte sous la forme d'une chaîne de caractère.
reponse = InputBox(prompt[,title][,default][,xpos][,ypos] [,helpfile,context])
Buttons = { }

--------------------
Les userforms
--------------------

* UserForm *

PréCharger un UserForm : Load UserForm1
Afficher un UserForm : UserForm1.Show
Cacher un UserForm : UserForm1.Hide
Décharger un UserForm : Unload UserForm1

* CheckBoxes *

Assigner un état clické à une checkBox : Sheets(1).CheckBox1.Value = true

* TextBox *

remplir un champ : UserForm1.champ1 = "FR"
Mettre le focus sur un champ : UserForm1.TextBox13.SetFocus
Mettre le focus sur un Bouton : UserForm1.CommandButton1.SetFocus

* Ordre de Tabulation *

Afin de respecter un ordre de tabulation ("Enter" ou "Tab")

--------------------
événements
--------------------

OnKey

lancer la prog launchprg lors d'un appui sur la touche "1" : application.onkey "1","launchprg"
ne fait rien lors d'un appui sur la touche "1" : application.onkey "1",""
rends sa fonction d'origine à la touche "1" : application.onkey "1"

OnTime

Démarrage de prog, 5 secondes après avoir lancé Test
Application.OnTime Now + TimeValue("00:00:05"), "prog"


OnRepeat, OnUndo, OnWindows


* Gestion des Erreurs *

On Error Resume Next 'saute la ligne en cas d'erreur
On error Goto finprg 'va à la ligne finprg: en cas d'erreur
finprg:
On Error GoTo 0 ' arrete la détéction d'erreur
Exit : L’instruction Exit permet de quitter un bloc Do...Loop, For...Next, Function,
ou Sub. [ Exit Do - Exit For - Exit Function - Exit Sub]


****************************************************************************************************
****************************************************************************************************
Fonctions EXCEL
****************************************************************************************************
****************************************************************************************************
Faire une liste déroulante
1) Créer un nom d ensemble de cellulues Selection des cells --> Insertion --> nom --> définir
2) Selection des cellules accueilant les listes déroulantes
3) Donnée --> Validation --> Autoriser --> Liste --> Ecrire le nom d ensemble dans Source

Sauvegarder un fichier en tant que macro complémentaire

With ActiveWorkbook
.saveas "C:\Temp\Zaza.xla", xlAddIn
.IsAddin = True
.Save
End With

****************************************************************************************************
****************************************************************************************************
FONCTIONS READY - Boite à outils
****************************************************************************************************
****************************************************************************************************


---------------------------------------------------------
Recopie des cellules d'un workbook excel non ouvert
(GetDataFromClosedWorkbook nom_fichier_UNC, "F31:F32", "A1", False )
---------------------------------------------------------
Function GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, TargetRange As range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library

Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset, dbConnectionString As String
Dim TargetCell As range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & "ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
Set TargetCell = TargetRange.Cells(1, 1)
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ' close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
GetDataFromClosedWorkbook = True
On Error GoTo 0
Exit Function
InvalidInput:
GetDataFromClosedWorkbook = False
End Function

---------------------------------------------------------
Retourne "true" si un fichier existe
---------------------------------------------------------
Private Function FileExist(File As String) As Boolean
Dim L As Long
On Error GoTo FExErr
L = FileLen(File)
FileExist = True
Exit Function
FExErr: FileExist = False
Exit Function
End Function

---------------------------------------------------------
Retourne "true" si un fichier existe
---------------------------------------------------------
Private Function FileExist(FileUNC As String) As Boolean
FileExist = IIf (Dir(fileUNC) = fileUNC,True, False)
End Function

---------------------------------------------------------
IMPORTE UN FICHIER CSV DANS UNE FEUILLE EXCEL
---------------------------------------------------------
Sub importCSVfile(file)

Sheets("Transfert").Range("A1:BB500").ClearContents
With Sheets("Transfert").QueryTables.Add(Connection:="TEXT;C:\Report.csv", Destination:=Sheets("Transfert").Range("A1"))
.Name = "Report"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 4, 4, 4, 4, 4, 2)
.Refresh BackgroundQuery:=False
End With
Sheets("Transfert").Range("N1").FormulaR1C1 = "User"
End Sub

----------------------------------------------------------
renvoie les valeurs d'une plage de cellules (srcRange)
d'une feuille (srcSheet) d'un fichier (srcFile) ferme
dans un tableau (outArr) le paramètre TTL indique si
la plage a ou non une ligne d'entêtes
Ex : GetExternalData nomduFichier, sourceSheetname, sourcerange, False, Arr
----------------------------------------------------------

Sub GetExternalData(srcFile As String, srcSheet As String, srcRange As String, TTL As Boolean, outArr As Variant)
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As Integer
Dim Arr

Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & srcFile & ";" & "Extended Properties=""Excel 8.0;" & "HDR=" &amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp; HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" & srcRange & "`" Else: myCmd.CommandText = "SELECT * from `" & srcSheet & "$" & srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lignes
For RS_f = 0 To myRS.Fields.Count - 1 'colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing
outArr = Arr
End Sub

---------------------------------------------------------
Retourne le username de windows
---------------------------------------------------------
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255

strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
UserNameWindows = If (CBool(GetUserName(strBuffer, lngLen)) ,Left$(strBuffer, lngLen - 1),"")

End Function

----------------------------------------------------------
déplace le curseur de nb positions vers la direction "direction"
Direction = "{LEFT}", "{RIGHT}"
----------------------------------------------------------
Sub arrowkeyleft(nb,direction)
for x = 1 to nb
Application.SendKeys "{LEFT}", True
Next
End Sub

----------------------------------------------------------
Fermeture Automatique
----------------------------------------------------------
mettre dans thiworkbook
--------------------
Private Sub Workbook_Open()
Debut = Now
FermAuto
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Debut = Now
FermAuto1
End Sub

mettre ds un module
--------------------
Option Explicit
Public Debut, DebutS, Annul As Byte
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub FermAuto()
DebutS = Debut + TimeValue("02:00:00") ' Modifier ici la durée - actuellement 2 h sec.
Application.OnTime DebutS, "FermAuto2"
End Sub
Sub FermAuto1()
On Error Resume Next
Application.OnTime DebutS, "FermAuto2", , "False"
FermAuto
End Sub
Sub FermAuto2()
UserForm1.Show
Application.OnTime Now + TimeValue("00:00:10"), "FermAuto3" 'NE PAS MODIFIER CETTE DUREE
End Sub
Sub FermAuto3()
If Annul <> 1 Then
ActiveWorkbook.Save
On Error Resume Next
Application.OnTime DebutS, "Ferauto2", , "False"
ActiveWorkbook.Close
End If
End Sub

----------------------------------------------
TROUVE LA POSITION D'UN VARIANT DANS UN ARRAY
-----------------------------------------------
This function returns the index of an item in a one/two-dimensional array.The function returns -1 if the item was not found
value: [Variant] Lookup value.
iColumn: (Optional) [Long] If the array has two dimensions, iColumn specifies which column (2nd dimension) will be searched.
iStart: (Optional) [Long] Determines where the search will be started.
------------------------------------------------
Function FindInArray(value, vArray As Variant, Optional iColumn, Optional iStart) As Long
FindInArray = -1
Dim i As Long, iCol As Long, iSta As Long, iTwo As Long

' check if vArray has two dimensions
On Error Resume Next
i = UBound(vArray, 2)
iTwo = IIf(Err.Number = 0, 1, -1)
On Error GoTo 0

' check variables
If IsMissing(iColumn) Or Not IsNumeric(iColumn) Then_
iCol = iTwo Else iCol = CLng(iColumn)
If IsMissing(iStart) Or Not IsNumeric(iStart) Then_
iSta = LBound(vArray, 1) Else iSta = CLng(iStart)
If iSta < itwo =" -1" i =" 1" findinarray =" i" i =" iSta" findinarray =" i">LanceIE()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "http://dj.joss.free.fr"
IE.AddressBar = True
IE.MenuBar = True
IE.Toolbar = True
IE.Width = 800
IE.Height = 600
IE.Resizable = True
IE.Visible = True
Set IE = Nothing
End Sub

-------------------------------------------------
donne le num de la semaine de la date fournie
-------------------------------------------------
Function NOSEM(D As Date) As Long
D = Int(D)
NOSEM = DateSerial(Year(D + (8 - WeekDay(D)) Mod 7 - 3), 1, 1)
NOSEM = ((D - NOSEM - 3 + (WeekDay(NOSEM) + 1) Mod 7)) \ 7 + 1
End Function

The WorkbookIsOpen Function

Private Function WorkbookIsOpen(wbname) As Boolean
'   Returns TRUE if the workbook is open
Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function