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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
| Dim f, NbCol, NomTableau, TblBD()
Private Sub UserForm_Initialize()
NomTableau = "Tableau1"
TblBD = Range(NomTableau).Value
NbCol = UBound(TblBD, 2)
Set d = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 5)) = ""
Next i
Me.ChoixListBox1.List = d.keys
For i = 1 To d.Count: Me.ListBox1.Selected(i) = False: Next i
Set d = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 6)) = ""
Next i
Me.ChoixListBox2.List = d.keys
Set d = CreateObject("scripting.dictionary")
d.comparemode = vbTextCompare
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 7)) = ""
Next i
Me.ChoixListBox3.List = d.keys
Me.ListBox1.ColumnCount = NbCol
Me.ListBox1.List = TblBD
EnteteListBox
End Sub
Sub EnteteListBox()
x = Me.ListBox1.Left + 8
Y = Me.ListBox1.Top - 20
For c = 1 To NbCol
Set Lab = Me.Controls.Add("Forms.Label.1")
Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
Lab.ForeColor = vbBlack
Lab.Top = Y
Lab.Left = x
Lab.Height = 24
Lab.Width = Range(NomTableau).Columns(c).Width * 1#
x = x + Range(NomTableau).Columns(c).Width * 1
tempcol = tempcol & Range(NomTableau).Columns(c).Width * 1# & ";"
Next c
tempcol = tempcol
On Error Resume Next
Me.ListBox1.ColumnWidths = tempcol
On Error GoTo 0
End Sub
Private Sub ChoixListBox1_change()
Affiche
End Sub
Private Sub ChoixListBox2_change()
Affiche
End Sub
Private Sub ChoixListBox3_change()
Affiche
End Sub
Sub Affiche()
Set dchoisis1 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.ChoixListBox1.ListCount - 1
If Me.ChoixListBox1.Selected(i) Then dchoisis1(Me.ChoixListBox1.List(i, 0)) = ""
Next i
Set dchoisis2 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.ChoixListBox2.ListCount - 1
If Me.ChoixListBox2.Selected(i) Then dchoisis2(Me.ChoixListBox2.List(i, 0)) = ""
Next i
Set dchoisis3 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.ChoixListBox3.ListCount - 1
If Me.ChoixListBox3.Selected(i) Then dchoisis3(Me.ChoixListBox3.List(i, 0)) = ""
Next i
n = 0: Dim Liste()
Set dsynthese = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
tmp = TblBD(i, 5)
tmp2 = TblBD(i, 6)
tmp3 = TblBD(i, 7)
If (dchoisis1.exists(tmp) Or dchoisis1.Count = 0) _
And (dchoisis2.exists(tmp2) Or dchoisis2.Count = 0) _
And (dchoisis3.exists(tmp3) Or dchoisis3.Count = 0) Then
n = n + 1
ReDim Preserve Liste(1 To NbCol, 1 To n)
For k = 1 To NbCol: Liste(k, n) = TblBD(i, k): Next k
dsynthese(TblBD(i, 8)) = dsynthese(TblBD(i, 8)) + 1
End If
Next i
If n > 0 Then
Me.ListBox1.Column = Liste
Me.ListSynthese.Clear
j = 0
For Each c In dsynthese
Me.ListSynthese.AddItem c
Me.ListSynthese.List(j, 1) = dsynthese(c)
j = j + 1
Next c
Else
Me.ListBox1.Clear
Me.ListSynthese.Clear
End If
End Sub
Private Sub B_result_Click()
Set f = Sheets("result")
f.[A2:B10].ClearContents
f.[A2].Resize(Me.ListSynthese.ListCount, 2) = Me.ListSynthese.List
f.[D2:D10].ClearContents
ligne = 2
For i = 0 To Me.ChoixListBox1.ListCount - 1
If Me.ChoixListBox1.Selected(i) Then f.Cells(ligne, "D") = ChoixListBox1.List(i): ligne = ligne + 1
Next i
f.[E2:E10].ClearContents
ligne = 2
For i = 0 To Me.ChoixListBox2.ListCount - 1
If Me.ChoixListBox2.Selected(i) Then f.Cells(ligne, "E") = ChoixListBox2.List(i): ligne = ligne + 1
Next i
f.[F2:F10].ClearContents
ligne = 2
For i = 0 To Me.ChoixListBox3.ListCount - 1
If Me.ChoixListBox3.Selected(i) Then f.Cells(ligne, "F") = ChoixListBox3.List(i): ligne = ligne + 1
Next i
End Sub |
