Option Explicit
Option Compare Text
Dim NbLignes As Integer
Dim LigDeb As Integer
Dim Noaction As Boolean
Dim MatchLig As Long
Dim Titre(3) As String
Dim TypeRech As Integer
Dim DicoList
Dim DicoLigne
Dim Tablo As Variant
Dim TL As Variant
Dim C0 As String, C1 As String, C2 As String
'tableau du combo1
Public Sub faireList1()
Dim Lig As Long
VoirColonne
Set DicoList = CreateObject("Scripting.Dictionary")
Set DicoLigne = CreateObject("Scripting.Dictionary")
With Sheets("Base")
For Lig = LigDeb To NbLignes
If Not DicoList.Exists(.Cells(Lig, C0).Value) Then
DicoList.AdD .Cells(Lig, C0).Value, .Cells(Lig, C0).Value
DicoLigne.AdD Lig, Lig
End If
Next Lig
End With
Tablo = DicoList.items
TL = DicoLigne.items
End Sub
'tableau du combo2
Public Sub faireList2()
Dim Lig As Long
Set DicoList = CreateObject("Scripting.Dictionary")
With Sheets("Base")
For Lig = LigDeb To NbLignes
If .Cells(Lig, C0).Value = ComboBox1.Text Then
If Not DicoList.Exists(.Cells(Lig, C1).Value) Then
DicoList.AdD .Cells(Lig, C1).Value, .Cells(Lig, C1).Value
End If
End If
Next Lig
End With
Tablo = DicoList.items
End Sub
Public Sub faireList3()
Dim Lig As Long
VoirColonne
Set DicoList = CreateObject("Scripting.Dictionary")
Set DicoLigne = CreateObject("Scripting.Dictionary")
With Sheets("Base")
For Lig = LigDeb To NbLignes
If .Cells(Lig, C0).Value = ComboBox1.Text And .Cells(Lig, C1).Value = ComboBox2.Text Then
If Not DicoList.Exists(.Cells(Lig, C2).Value) Then
DicoList.AdD .Cells(Lig, C2).Value, .Cells(Lig, C2).Value
DicoLigne.AdD Lig, Lig
End If
End If
Next Lig
End With
Tablo = DicoList.items
TL = DicoLigne.items
End Sub
Sub VoirColonne()
Select Case TypeRech
Case 0: C0 = "AO": C1 = "AN": C2 = "A"
Case 1: C0 = "AN": C1 = "AO": C2 = "A"
Case 2: C0 = "A": C1 = "AO": C2 = "AN"
Case 3: C0 = "A"
End Select
End Sub
'Remplir et vider tout les TextBox
Sub InitFormulaire(Optional Mode As Boolean = False)
Dim Ctl As Control
With Sheets("Base")
'Boucle sur tout les contrôle de l'UF
'Ctl étant une variable objet se substitue au control
For Each Ctl In Me.Controls
'Si la propriété TAG d'un contrôle n'est pas vide c'est que c'est un TextBox
'Note : Les propriétés TAG des texBox concernés sont initialiser
'Avec les N° de colonne où il doivent "pécher" la donnée
If Ctl.Tag <> "" Then
'mode =true --> Vider les textBox
If Mode Then 'si Mode = true vide le Textbox
Ctl = ""
Else 'remplir le textbox avec la donnée de la BD qui se trouve à la ligne
'MatchLig, le N° de la colonne est dans le TAG
'Cint transforme la valeur de la propriété TAG qui est en String
'en valeur numérique compatible avec un N° de colonne
Ctl = Cells(MatchLig, CInt(Ctl.Tag)).Value
End If
End If
Next Ctl
End With
End Sub
Sub VoirControl(Mode As Boolean)
ComboBox2.Visible = Mode
ComboBox3.Visible = Mode
TitCB2.Visible = Mode
TitCB3.Visible = Mode
End Sub
Private Sub ComboBox1_Change()
If Noaction Then Exit Sub 'désactive l'évenement
If TypeRech = 3 Then
MatchLig = TL(ComboBox1.ListIndex)
'Rempli le formulaire
InitFormulaire
Else
faireList2
Trier Tablo, LBound(Tablo), UBound(Tablo)
ComboBox2.List = Tablo
End If
End Sub
Private Sub ComboBox2_Change()
If Noaction Then Exit Sub 'désactive l'évenement
InitFormulaire True 'vide le formulaire
faireList3
TrierFIN Tablo, LBound(Tablo), UBound(Tablo)
ComboBox3.List = Tablo
End Sub
Private Sub ComboBox3_Change()
If Noaction Then Exit Sub 'désactive l'évenement
'Initialise le N° de la ligne où se situe les données
MatchLig = TL(ComboBox3.ListIndex)
'Rempli le formulaire
InitFormulaire
End Sub
Private Sub Frame2_Click()
End Sub
Private Sub OptionButton1_Click()
InitFormulaire True 'vide le formulaire
TypeRech = 0
Remplir1
End Sub
Private Sub OptionButton2_Click()
InitFormulaire True 'vide le formulaire
TypeRech = 1
Remplir1
End Sub
Private Sub OptionButton3_Click()
InitFormulaire True 'vide le formulaire
TypeRech = 2
Remplir1
End Sub
Private Sub OptionButton4_Click()
InitFormulaire True 'vide le formulaire
TypeRech = 3
InitLesCombo
faireList1
TrierFIN Tablo, LBound(Tablo), UBound(Tablo)
ComboBox1.List = Tablo
' Remplir1
End Sub
Private Sub UserForm_Initialize()
Dim i
'Initialise le tableau Titre() pour les label audessus des combo
Titre(0) = "Sociétés,Banques,Codes"
Titre(1) = "Banques,Sociétés,Codes"
Titre(2) = "Codes,Sociétés,Banques"
Titre(3) = "Code uniquement," & Chr(32) & "," & Chr(32)
'Nombre de ligne dans la BD
NbLignes = Sheets("Base").Range("AN65536").End(xlUp).Row
LigDeb = 3 'N° de ligne où commencer
Remplir1
End Sub
Sub Remplir1()
Noaction = True
InitLesCombo
faireList1
Trier Tablo, LBound(Tablo), UBound(Tablo)
ComboBox1.List = Tablo
Noaction = False
End Sub
Sub InitLesCombo()
Dim TB
'Vider tout les combo
ComboBox1.Clear: ComboBox2.Clear: ComboBox3.Clear
ComboBox2.Visible = Not TypeRech = 3
ComboBox3.Visible = Not TypeRech = 3
'Changer les titres des combobox suivant le choix du tri
TB = Split(Titre(TypeRech), ",")
TitCB1 = TB(0): TitCB2 = TB(1): TitCB3 = TB(2)
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub CommandButton3_Click()
Unload Me
UserForm1.Show
End Sub
Private Sub CommandButton2_Click()
Set Ws = Sheets.AdD
Ws.PageSetup.Orientation = xlLandscape
Ws.Paste
ActiveSheet.PageSetup.CenterHorizontally = True
ActiveSheet.PageSetup.CenterVertically = True
UserForm1.PrintForm
End Sub
' Trier par le milieu et mémorise la ligne cible
' Trie les nombres en ordre croissant (ce qu'Excel ne fait pas)
Sub TrierFIN(ByRef TBCB, AdG, AdD)
Dim Ml
Dim Ag, Ad, Buff
Ml = TBCB((AdG + AdD) \ 2)
Ag = AdG: Ad = AdD
Do
Do While Cmp(Ml, TBCB(Ag)): Ag = Ag + 1: Loop
Do While Cmp(TBCB(Ad), Ml): Ad = Ad - 1: Loop
If Ag <= Ad Then
Buff = TBCB(Ag): TBCB(Ag) = TBCB(Ad): TBCB(Ad) = Buff
Buff = TL(Ag): TL(Ag) = TL(Ad): TL(Ad) = Buff
Ag = Ag + 1: Ad = Ad - 1
End If
Loop While Ag <= Ad
If Ag < AdD Then Call TrierFIN(TBCB, Ag, AdD)
If AdG < Ad Then Call TrierFIN(TBCB, AdG, Ad)
End Sub
' Trier par le milieu ,suivant une idée de Jacques Boisgontier
' Trie les nombres en ordre croissant (ce qu'Excel ne fait pas)
Sub Trier(ByRef TBCB, AdG, AdD)
Dim Ml
Dim Ag, Ad, Buff
Ml = TBCB((AdG + AdD) \ 2)
Ag = AdG: Ad = AdD
Do
Do While Cmp(Ml, TBCB(Ag)): Ag = Ag + 1: Loop
Do While Cmp(TBCB(Ad), Ml): Ad = Ad - 1: Loop
If Ag <= Ad Then
Buff = TBCB(Ag): TBCB(Ag) = TBCB(Ad): TBCB(Ad) = Buff
Ag = Ag + 1: Ad = Ad - 1
End If
Loop While Ag <= Ad
If Ag < AdD Then Call Trier(TBCB, Ag, AdD)
If AdG < Ad Then Call Trier(TBCB, AdG, Ad)
End Sub