'http://www.excel-downloads.com/forum/93237-associer-bouton-alerte-des-donnees.html
Dim nomFeuilleRecapP As String
Sub InitialisationDesMenusSouris(Optional bidon As String)
MenuCell "Debut", "RECAP DES DATES > AUJOURDHUI"
End Sub
Sub auto_open(Optional bidon As String)
InitialisationDesMenusSouris
End Sub
Function MenuCell(stCde As String, stMess As String)
' Rajout d'une entrée dans menu contextuel souris droit
Dim barreDeControle As CommandBarControls
Dim barreBouton As CommandBarButton
Set barreDeControle = CommandBars("Cell").Controls
Set barreBouton = barreDeControle.Add(msoControlButton, Temporary:=True)
barreBouton.Caption = stMess
barreBouton.OnAction = stCde
End Function
Sub Debut()
AjouteUneFeuille ("RECAP")
BoucleDesFeuilles
Sheets(nomFeuilleRecapP).Select
Range("a1").Select
End Sub
Sub BoucleDesFeuilles()
nbFeuilles = Sheets.Count
For feuille = 1 To nbFeuilles
If Left(Sheets(feuille).Name, 5) = "RECAP" Then GoTo sautFeuilleRecap
RechercheDesColonnesLivraisonAtelier feuille
sautFeuilleRecap:
Next feuille
End Sub
Sub RechercheDesColonnesLivraisonAtelier(feuille)
Sheets(feuille).Activate
Range("a1").Select
With ActiveSheet.UsedRange
Set c = .Find("LIVRAISON", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
ligne = c.Row
colonne = c.Column
RecupereLesInfosColonne ligne, colonne
Do
Set c = .FindNext(c)
adresseSuivante = c.Address
ligne = c.Row
colonne = c.Column
RecupereLesInfosColonne ligne, colonne
Loop While Not c Is Nothing And adresseSuivante <> firstAddress
End If
End With
Set c = Nothing
End Sub
Sub RecupereLesInfosColonne(ligne, colonne)
DerniereLigneDeLaFeuille colonne, derniereLigneUtilisee
RechercheDesDatesSuperieuresAaujourdhui ligne, colonne, derniereLigneUtilisee
End Sub
Sub RechercheDesDatesSuperieuresAaujourdhui(ligne, colonne, derniereLigneUtilisee)
Set plg = Range(Cells(ligne + 1, colonne), Cells(derniereLigneUtilisee, colonne))
nomFeuille = ActiveSheet.Name
texteAafficher = "CLIQUER ICI POUR RETROUVER CETTE DATE"
infoBulle = "CLIQUER ICI POUR RETROUVER CETTE DATE"
For Each dateAtelier In plg
Select Case dateAtelier
Case Is >= Date
Sheets(nomFeuille).Select
Range(dateAtelier.Offset(0, -3), dateAtelier.Offset(0, 1)).Select
'Stop
adresse = dateAtelier.Address
'ligneDate = dateAtelier.Row
RecupDeLaligneTrouvee ligne
colonne = 6
'Stop
LienHypertexte ligne, colonne, nomFeuille, adresse, texteAafficher, infoBulle
MiseEnformeDeLaLigne ligne, colonne, nomFeuille, adresse
Sheets(nomFeuille).Select
Case Else
End Select
Next
End Sub
Sub LienHypertexte(ligne, colonne, nomFeuille, adresse, texteAafficher, infoBulle)
sousAdresse = "'" + nomFeuille + "'!" + adresse
With ActiveSheet
.Hyperlinks.Add Anchor:=ActiveSheet.Cells(ligne, colonne), Address:="", _
SubAddress:=sousAdresse, ScreenTip:=infoBulle, TextToDisplay:= _
texteAafficher
End With
End Sub
Sub MiseEnformeDeLaLigne(ligne, colonne, nomFeuille, adresse)
Cells(ligne, 1).Select
'Selection.NumberFormat = "m/d/yyyy"
Selection.NumberFormat = "[$-40C]dd-mmm-yy;@"
With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 5
End With
Cells(ligne, 2).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 7
End With
Cells(ligne, 3).Select
'Selection.NumberFormat = "m/d/yyyy"
Selection.NumberFormat = "[$-40C]dd-mmm-yy;@"
With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 50
End With
Cells(ligne, 4).Select
'Selection.NumberFormat = "m/d/yyyy"
Selection.NumberFormat = "[$-40C]dd-mmm-yy;@"
With Selection.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
End With
End Sub
Sub RecupDeLaligneTrouvee(ligne)
'Stop
Selection.Copy
Sheets(nomFeuilleRecapP).Select
DerniereLigneDeLaFeuille 1, derniereLigneUtilisee
Cells(derniereLigneUtilisee + 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ligne = derniereLigneUtilisee + 1
End Sub
Sub DerniereLigneDeLaFeuille(colonne, derniereLigneUtilisee)
nbLignes = ActiveSheet.Rows.Count
Select Case TypeName(colonne)
Case "String" 'une lettre A65536
derniereLigneUtilisee = Range(colonne & LTrim(Str(nbLignes))).End(xlUp).Row
Case Else 'un chiffre
derniereLigneUtilisee = Cells(nbLignes, colonne).End(xlUp).Row
End Select
End Sub
Sub AjouteUneFeuille(nomDeLaFeuille)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
TueSiFeuilleExiste nomDeLaFeuille
Set feuilleAjoutee = Sheets.Add(before:=Sheets(1))
ConvertiLaDate laDate
feuilleAjoutee.Name = nomDeLaFeuille + " " + laDate
nomFeuilleRecapP = feuilleAjoutee.Name
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub TueSiFeuilleExiste(nomDeLaFeuille)
For i = 1 To Sheets.Count
If Left(Sheets(i).Name, 5) = nomDeLaFeuille Then Sheets(i).Delete: Exit For
Next i
End Sub
Sub ConvertiLaDate(laDate)
tableau = Split(Date, "/")
For i = UBound(tableau) To 0 Step -1
Select Case i
Case Is = UBound(tableau)
laDate = tableau(i)
Case Else
laDate = tableau(i) + "-" + laDate
End Select
Next i
End Sub
