annee 2017

EXCEL ANNEE 2017

L'heure est venue de vous presenter

Une excel et bonne annee 2017 !

De la part de toute l equipe de VeriTi

Image 1

Bienvenue

sur le site des amis d'Excel

excel.veriti.net ou fr

Image 2

Musee

Visitez le "Musee VeriTi" 24h/24 - 7j/7, des "pepites" vous y attendent

Voir la suite
Image 3

Hommage

Thierry POURTIER alias 'Ti'
s'en est alle brutalement le samedi 13 novembre 2010...

Voir la suite
Image 4

Historique

Juillet 2013 : A l'occasion du 10eme anniversaire de VeriTi, j'ai décide de réparer et de remettre en ligne le site, avec une nouvelle version plus structurée tout en gardant les mêmes fichiers Excel

Voir la suite

Membre

+ Enregistrement
Articles >Souris > Liste de choix

Liste de choix

Publié par veriland le 07-Aug-2013 16:30 (1234 lectures)

souris

 

Cette procédure permet en outre d'avoir la liste triée dans le menu

 

module

 

'***********************************
'partie à placer dans Thisworkbook
'***********************************
Option Explicit
'Macro de Ti alias Thierry Pourtier / juin 2002
'cela ne nous rajeunit pas !!!

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim Ctrl As CommandBarControl
Dim Cel As Range, Plage As Range
Dim NbItem As Long, Boucle As Long
Dim DejaPris As Boolean
  
  For Each Ctrl In Application.CommandBars("cell").Controls
    If Ctrl.Tag = "brccm" Then Ctrl.Delete
  Next Ctrl
  With ActiveCell
    If .Row = 1 Then Exit Sub
    ReDim ListItem(1 To .Row)
    Set Plage = Range(Cells(1, .Column), .Offset(-1, 0))
  End With

  For Each Cel In Plage
    'inutile de boucler au delà de NbItem, le reste sera vide !
    For Boucle = 1 To NbItem
      If Cel.Value = ListItem(Boucle) Then
        DejaPris = True
        Exit For
      End If
    Next Boucle
    
    If Not DejaPris And Cel.Value <> "" Then
      NbItem = NbItem + 1
      ListItem(NbItem) = Cel.Value
    End If
    DejaPris = False
  Next Cel
  
  'tri du tableau et affectation au menu
  If NbItem > 0 Then
    TrieTableau ListItem, 1, NbItem
    'il faut boucler à l'envers pour retrouver le bon ordre
    For Boucle = NbItem To 1 Step -1
      With Application.CommandBars("cell").Controls _
        .Add(Type:=msoControlButton, before:=6, temporary:=True)
        .Caption = CStr(ListItem(Boucle))
        .OnAction = "EcrisValeur(" & Boucle & ")"
        .Tag = "brccm"
      End With
    Next Boucle
  End If
End Sub

 

module

 
'******************************
'partie à placer dans un module
'******************************
Option Explicit
'Macro de Ti alias Thierry Pourtier / juin 2002 /
'cela ne nous rajeunit pas !!!
Public ListItem() As Variant

Sub TrieTableau(PTableau, Deb As Long, Fin As Long)
' cette procédure travaille récursivement
Dim IndiceInf As Long, IndiceSup As Long
Dim Temp, Pivot
  IndiceInf = Deb
  IndiceSup = Fin
  Pivot = UCase(PTableau((Deb + Fin) 2))
  Do
    While UCase(PTableau(IndiceInf)) < Pivot
      IndiceInf = IndiceInf + 1
    Wend
    While Pivot < UCase(PTableau(IndiceSup))
      IndiceSup = IndiceSup - 1
    Wend
    If IndiceInf <= IndiceSup Then
      Temp = PTableau(IndiceInf)
      PTableau(IndiceInf) = PTableau(IndiceSup)
      PTableau(IndiceSup) = Temp
      IndiceInf = IndiceInf + 1
      IndiceSup = IndiceSup - 1
    End If
  Loop Until IndiceInf > IndiceSup
  If Deb < IndiceSup Then TrieTableau PTableau, Deb, IndiceSup
  If IndiceInf < Fin Then TrieTableau PTableau, IndiceInf, Fin
End Sub

Sub EcrisValeur(PIndex)
  ActiveCell.Value = ListItem(PIndex)
End Sub


Naviguer à travers les articles
Procédures évènementielles Article suivant
Note 0.00/5
Note: 0.0/5 (0 votes)
Les votes sont désactivés !
Les commentaires appartiennent à leurs auteurs. Nous ne sommes pas responsables de leur contenu.
Auteur Commentaire en débat

Astuces
Sélection d'articles par Catégorie
Userform
Feuille
Cel / Col / Lig
Souris
Impression
Images
Commentaires
Evènements
Fichier
Trucs et astuces
Divers
FAQ Acyd
carte des membres

Carte des membres

Menu Principal
Haut de page des téléchargements
Copyright 2013 Powered by XOOPS © 2001-2013