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 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176
| Dim f, bd, TabBD(), ColCombo(), ColVisu(), NcolVisu
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
B_tout_Click
Set bd = f.Range("A2:F" & f.[A65000].End(xlUp).Row)
TabBD = bd.Value2
ColCombo = Array(1, 2, 3, 4)
ColVisu = Array(5, 6)
For c = 1 To UBound(ColCombo) + 1: ListeCol c: Next c
For i = 1 To UBound(ColCombo) + 1: Me("label" & i) = f.Cells(1, ColCombo(i - 1)): Next i
'-- en têtes de colonne ListBox
x = Me.ListBox1.Left + 8
y = Me.ListBox1.Top - 12
For Each k In ColVisu
Set Lab = Me.Controls.Add("Forms.Label.1")
Lab.Caption = f.Cells(1, k)
Lab.Top = y
Lab.Left = x
x = x + f.Columns(k).Width * 1#
tempCol = tempCol & f.Columns(k).Width * 1# & ";"
Next
tempCol = Left(tempCol, Len(tempCol) - 1)
Me.ListBox1.ColumnCount = UBound(ColVisu) + 1
Me.ListBox1.ColumnWidths = tempCol
'-- labels textbox
NcolVisu = UBound(ColVisu) + 1
affich.Enabled = False
End Sub
Sub ListeCol(noCol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(TabBD)
ok = True
For Cb = 0 To UBound(ColCombo)
ColBD = ColCombo(Cb)
If Cb + 1 <> noCol Then
If Not TabBD(i, ColBD) Like Me("comboBox" & Cb + 1) Then ok = False
End If
Next Cb
If ok Then
tmp = TabBD(i, ColCombo(noCol - 1))
d(tmp) = ""
End If
Next i
d("*") = ""
temp = d.keys
Tri temp, LBound(temp), UBound(temp)
Me("ComboBox" & noCol).List = temp
End Sub
Private Sub B_tout_Click()
On Error Resume Next
ActiveSheet.ShowAllData
For i = 1 To 4
Me(ColCombo(i)) = "*"
Next i
End Sub
Private Sub ListBox1_Click()
Dim CurrentRecord As Long
Dim link As String
On Error Resume Next
CurrentRecord = ListBox1.ListIndex + 2
link = Sheets("bd").Cells(CurrentRecord, 6).Hyperlinks(1).Address
ThisWorkbook.FollowHyperlink Address:=link, NewWindow:=True
End Sub
Private Sub ComboBox1_DropButtonClick()
ListeCol 1
End Sub
Private Sub ComboBox2_DropButtonClick()
ListeCol 2
End Sub
Private Sub ComboBox3_DropButtonClick()
ListeCol 3
End Sub
Private Sub ComboBox4_DropButtonClick()
ListeCol 4
End Sub
Private Sub ComboBox1_Change()
'Affiche
With Me.affich
If Me.ComboBox1.ListIndex < 0 Then
.Enabled = False
Else
Me.affich.Enabled = True
End If
End With
End Sub
Private Sub ComboBox2_Change()
' Affiche
With Me.affich
If Me.ComboBox2.ListIndex < 0 Then
.Enabled = False
Else
.Enabled = True
End If
End With
End Sub
Private Sub ComboBox3_Change()
' Affiche
With Me.affich
If Me.ComboBox3.ListIndex < 0 Then
.Enabled = False
Else
.Enabled = True
End If
End With
End Sub
Private Sub ComboBox4_Change()
'Affiche
With Me.affich
If Me.ComboBox4.ListIndex < 0 Then
.Enabled = False
Else
.Enabled = True
End If
End With
End Sub
Private Sub affich_Click()
Dim Tbl()
cbx1 = Me.ComboBox1
cbx2 = Me.ComboBox2
cbx3 = Me.ComboBox3
cbx4 = Me.ComboBox4
n = 0
For i = 1 To UBound(TabBD)
If TabBD(i, ColCombo(0)) Like cbx1 And TabBD(i, ColCombo(1)) Like cbx2 _
And TabBD(i, ColCombo(2)) Like cbx3 And TabBD(i, ColCombo(3)) Like cbx4 Then
n = n + 1
ReDim Preserve Tbl(1 To NcolVisu, 1 To n)
c = 0
For Each k In ColVisu
c = c + 1
Tbl(c, n) = TabBD(i, k)
Next k
End If
Next i
If n > 0 Then
Me.ListBox1.Column = Tbl
Else
Me.ListBox1.Clear
End If
End Sub
Sub Tri(a, gauc, droi) ' Quick sort
ref = CStr(a((gauc + droi) \ 2))
g = gauc: d = droi
Do
Do While CStr(a(g)) < ref: g = g + 1: Loop
Do While ref < CStr(a(d)): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub |
Partager