Discussion :

[fred65200]

bonjour,
voici le code pour permettre une liste de validation, la liste étant dans un classeur fermé.

Les données sont récupérées et trier par ADO

Faire référence à Microsofr ActiveX Data Object X.0 Library

Le code dans un module de code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Option Explicit
 
Public i As Long
 
Dim maBarrePopUp As CommandBar
 
Dim tabCodes() As Variant
Dim nbElements As Long
 
Dim Cn As ADODB.Connection
Dim Cd As ADODB.Command
Dim Rst As ADODB.Recordset
 
Sub fred65200()
uffred65200.Show
End Sub
 
Function Quel_Provider(Fichier, hdr)
Dim Provid As String
Dim ExtProp As String
 
If Val(Application.Version) < 12 Then
    'avant Excel 2007
    Provid = "Microsoft.Jet.OLEDB.4.0"
    ExtProp = "Excel 8.0"
Else
    'excel 2007
    Provid = "Microsoft.ACE.OLEDB.12.0"
    ExtProp = "Excel 12.0"
End If
 
Quel_Provider = "Provider=" & Provid & _
    ";Data Source=" & Fichier & _
    ";Extended Properties=""" & ExtProp & _
    ";HDR=" & Application.Proper(hdr) & ";"""
 
End Function
 
Sub ListeADO()
 
Dim strSql As String
 
strSql = "SELECT * FROM 
[Listes$] ORDER BY codes ASC" ', valeurs ASC"
 
Set Cn = New ADODB.Connection
 
Cn.Open Quel_Provider(ThisWorkbook.Path & Application.PathSeparator & "Listes.xls", "yes")
 
Set Cd = New ADODB.Command
Cd.ActiveConnection = Cn
 
Set Rst = New ADODB.Recordset
 
Rst.Open strSql, Cn, adOpenKeyset ' adopenKeyset pour recordcount
nbElements = Rst.RecordCount
 
Set Rst = Cn.Execute(strSql)
 
ReDim Preserve tabCodes(1, nbElements)
 
i = 0
 
Do While Not Rst.EOF
'boucle sur les valeurs et implantation dans le tableau
    tabCodes(0, i) = Rst.Fields("codes").Value
    tabCodes(1, i) = Rst.Fields("valeurs").Value
    Rst.MoveNext
i = i + 1
Loop
 
Rst.Close: Cn.Close
Set Rst = Nothing: Set Cn = Nothing
 
End Sub
Sub PopUp() 'idée originale de Wilfried42  --> Je crois
On Error Resume Next
CommandBars("maBarrePopUp").Delete
On Error GoTo 0
 
ListeADO
 
Set maBarrePopUp = Application.CommandBars.Add("maBarrePopUp", msoBarPopup)
   For i = 0 To nbElements - 1
      With maBarrePopUp.Controls.Add(msoControlButton, 1, , , True)
         .Tag = i + 1
         .Caption = tabCodes(0, i)
         .OnAction = "Resultat(" & .Tag & ")"
      End With
   Next i
maBarrePopUp.ShowPopup
End Sub
Sub Resultat(index As Long)
    ActiveCell = tabCodes(0, CLng(index) - 1) 'maBarrePopUp.Controls(CLng(index)).Caption
    ActiveCell(1, 2) = tabCodes(1, CLng(index) - 1)
   ' ActiveCell(1, 3).Select
End Sub

le code de feuille pour la feuille où les listes doivent apparaître.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Option Explicit
 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim derLi As Long
derLi = Columns(1).Find("*", , , , , xlPrevious).Row + 1
If Not Intersect(Range("A2:A" & derLi), Target) Is Nothing And Target.Count = 1 Then
    PopUp
    Target(1, 3).Select
    Cancel = True
End If
End Sub

Le code de ThisWorkbook pour "imposer" les macros.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 Application.ScreenUpdating = False
 
' à la fermeture du classeur, on masque toute s les feuilles sauf la première
Sheets(1).Visible = True
For i = 2 To Sheets.Count
    Sheets(i).Visible = 2 'on ne peut visualiser les feuille que par VBA
Next
ThisWorkbook.Save
Application.ScreenUpdating = True
 
 
End Sub
 
 
Private Sub Workbook_Open()
Application.ScreenUpdating = False
'si les macros sont activées, on masque la feuille 1
' et affiche les autres
For i = 2 To Sheets.Count
    Sheets(i).Visible = True
Next
Sheets(1).Visible = 2 'on ne peut visualiser les feuille que par VBA
 
Application.ScreenUpdating = True
End Sub

Les classeurs démo en pièces jointes

Cordialement