Associer Bouton Alerte A Des Donnees

'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