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
| Option Explicit
Dim Fichier As String
Dim Ws As Worksheet
Dim NbLignes As Integer
Dim NoAction As Boolean
Dim Tmp
Private Sub UserForm_Initialize()
Set Ws = Sheets("Base")
With Ws
.AutoFilterMode = False
NbLignes = .Range("D65536").End(xlUp).Row
.Range("A2:O" & NbLignes).Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlYes
Tmp = .Range("D3:F" & NbLignes)
End With
Fichier = ThisWorkbook.Path & "\TmpImage.gif"
Alim_Combo 1
End Sub
Private Sub ComboBox1_Change()
If ComboBox1 <> "" Then Alim_Combo 2
End Sub
Private Sub ComboBox2_Change()
If ComboBox2 <> "" Then
Alim_Combo 3
Else
Me.ComboBox3.Clear
End If
End Sub
Private Sub ComboBox3_Change()
Dim MonImage As String
If Me.ComboBox3 <> "" Then
If TraceGraphique And Dir(Fichier) <> "" Then MonImage = Fichier
End If
Image1.Picture = LoadPicture(MonImage)
End Sub
Private Sub UserForm_Terminate()
If Dir(Fichier) <> "" Then Kill Fichier
Set Ws = Nothing
End Sub
Private Sub Alim_Combo(CbxIndex As Integer)
Dim Ref As String, Col As String, Mol As String
Dim MonDico As Object, Obj As Control
Dim j As Long, k As Long
Dim Tb
Set MonDico = CreateObject("scripting.dictionary")
Set Obj = Me.Controls("ComboBox" & CbxIndex)
Obj.Clear
Select Case CbxIndex
Case 1
For j = 1 To NbLignes - 2
Col = CStr(Tmp(j, 2))
If Col <> "" Then
Col = Format(Col, "0000")
If Not MonDico.Exists(Col) Then
k = k + 1
MonDico.Add Col, Col
End If
End If
Next j
Case 2
For j = 1 To NbLignes - 2
Col = Tmp(j, 2)
Ref = Tmp(j, 1)
If Ref <> "" Then Ref = Left(Ref, Len(Ref) - 1)
If Col = Val(Me.ComboBox1) And Ref <> "" Then
If Not MonDico.Exists(Ref) Then
k = k + 1
MonDico.Add Ref, Ref
End If
End If
Next j
Case 3
For j = 1 To NbLignes - 2
Col = CStr(Tmp(j, 2))
Ref = Tmp(j, 1)
If Ref <> "" Then Ref = Left(Ref, Len(Ref) - 1)
Mol = Tmp(j, 3)
If Col = Val(Me.ComboBox1) And Ref = Me.ComboBox2 And Mol <> "" Then
If Not MonDico.Exists(Mol) Then
k = k + 1
MonDico.Add Mol, Mol
End If
End If
Next j
End Select
If k > 0 Then
Tb = MonDico.items
Set MonDico = Nothing
Tri Tb, 0, k - 1
Obj.List = Tb
End If
Set Obj = Nothing
End Sub
Private Sub Tri(ByRef T, ByVal LoBound As Long, ByVal UpBound As Long)
Dim Hi As Long, Lo As Long, i As Long
Dim Med As String
If LoBound >= UpBound Then Exit Sub
i = Int((UpBound - LoBound + 1) * Rnd + LoBound)
Med = T(i)
T(i) = T(LoBound)
Lo = LoBound
Hi = UpBound
Do
Do While T(Hi) >= Med
Hi = Hi - 1
If Hi <= Lo Then Exit Do
Loop
If Hi <= Lo Then
T(Lo) = Med
Exit Do
End If
T(Lo) = T(Hi)
Lo = Lo + 1
Do While T(Lo) < Med
Lo = Lo + 1
If Lo >= Hi Then Exit Do
Loop
If Lo >= Hi Then
Lo = Hi
T(Hi) = Med
Exit Do
End If
T(Hi) = T(Lo)
Loop
Tri T, LoBound, Lo - 1
Tri T, Lo + 1, UpBound
End Sub
Private Function TraceGraphique() As Boolean
Dim Ref As String, Col As String, Mol As String
Col = Val(Me.ComboBox1.Value)
Ref = Me.ComboBox2.Value
Mol = Me.ComboBox3.Value
If Ref <> "" And Col <> "" And Mol <> "" Then
With Ws
.AutoFilterMode = False
With .Range("D2:F" & NbLignes)
.AutoFilter Field:=1, Criteria1:=Ref & "*"
.AutoFilter Field:=2, Criteria1:=Col
.AutoFilter Field:=3, Criteria1:=Mol
End With
If Dir(Fichier) <> "" Then Kill Fichier
On Error Resume Next
Worksheets("Feuil2").ChartObjects(1).Chart.Export Filename:=Fichier, filtername:="GIF"
On Error GoTo 0
TraceGraphique = Dir(Fichier) <> ""
.AutoFilterMode = False
End With
End If
End Function
Private Sub CommandButton1_Click()
Unload Me
End Sub |
Partager