Moteur de recherche à l'aide de vba

**Guizmonster** · 23/03/2020, 17h19

Bonjour à tous,

Je regarde pour faire un userform qui me permettra de chercher plus facilement des références dans un fichier contenant des milliers d'entrées.

J'ai commencé à me faire un fichier test pour tester ça avec mon faible niveau et je viens ici pour reposer des questions.

Le but est de venir faire une recherche dans les colonnes C et I. Les résultats viennent s'afficher au fur et à mesure dans la listbox 1 et les titres des colonnes dans la listbox 2.

Je voudrais utiliser les combobox pour affiner la recherche. J'ai 2 premières questions concernant celles-ci. Je viens récupérer pour la première les différences entrées dans la colonnes A pour pouvoir faire un choix mais est-il possible de retirer "Magasin B"? Peut-on avoir de base un case vide?

Je continue à bosser sur le reste.

Cordialement

**boisgontierjacques** · 23/03/2020, 19h06

Bonsoir,

Ceci n'est pas une BD. Il faut créer une colonne Magasin

Boisgontier

**Guizmonster** · 24/03/2020, 08h46

Envoyé par boisgontierjacques

Bonsoir,

Ceci n'est pas une BD. Il faut créer une colonne Magasin

Boisgontier

Le fichier original ne peut pas être modifié dans sa structure.

**boisgontierjacques** · 24/03/2020, 13h17

Bonjour,

Fait avec un pgm générique.
Il suufit de copier/coller la BD en A1
La recherche se fait dans toutes les colonnes.

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
98
99
100
101
102
103
Option Compare Text
Dim TblBD(), Choix(), NomTableau, NbCol, ChoixCombo()
Private Sub UserForm_Initialize()
  NomTableau = "tableau1"
  NbCol = Range(NomTableau).Columns.Count      ' adapter
  TblBD = Range(NomTableau).Resize(, NbCol + 1).Value
  For i = 1 To UBound(TblBD): TblBD(i, NbCol + 1) = i: Next i
  ReDim Choix(1 To UBound(TblBD))
  For i = LBound(TblBD) To UBound(TblBD)
     NbCol = Range(NomTableau).Columns.Count
     For k = 1 To NbCol: Choix(i) = Choix(i) & TblBD(i, k) & "|": Next k
     Choix(i) = Choix(i) & i  ' no ligne BD
  Next i
  Me.ListBox1.List = TblBD
  EnteteListBox
  ChoixCombo = ListeMotsTab(Range(NomTableau))
  Me.ComboBox1.List = ListeMotsTab(Range(NomTableau))
  Me.ComboTri.List = Application.Transpose(Range(NomTableau).Offset(-1).Resize(1))  ' Ordre tri
End Sub
 
Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(Me.TextBox1, " ")
     tbl = Choix
     For i = LBound(mots) To UBound(mots)
       tbl = Filter(tbl, mots(i), True, vbTextCompare)
     Next i
     n = UBound(tbl) + 1
     If n > 0 Then
       ReDim Tbl2(LBound(tbl) To n + 1, 1 To NbCol + 1)
       For j = LBound(tbl) To UBound(tbl)
         a = Split(tbl(j), "|")
         For k = 0 To NbCol - 1: Tbl2(j, k + 1) = a(k): Next k
         Tbl2(j, k + 1) = a(k)
       Next j
       Me.ListBox1.List = Tbl2
      Else
       Me.ListBox1.Clear
      End If
    Else
      Me.ListBox1.List = TblBD
    End If
End Sub
 
 
Sub EnteteListBox()
  NbCol = Range(NomTableau).Columns.Count
  x = Me.ListBox1.Left + 8
  Y = Me.ListBox1.Top - 12
  For i = 1 To NbCol
    Set lab = Me.Controls.Add("Forms.Label.1")
    lab.Caption = Range(NomTableau).Offset(-1).Cells(1, i)
    lab.Top = Y
    lab.Left = x
    x = x + Int(Range(NomTableau).Columns(i).Width * 0.9)
    temp = temp & Int(Range(NomTableau).Columns(i).Width * 0.9) & ";"
  Next
 
  Me.ListBox1.ColumnCount = NbCol + 1
  temp = Left(temp, Len(temp) - 1)
  Me.ListBox1.ColumnWidths = temp
End Sub
 
Private Sub ComboTri_click()
  Dim tbl()
  colTri = Me.ComboTri.ListIndex
  tbl = Me.ListBox1.List
  TriMultiCol tbl, LBound(tbl), UBound(tbl), colTri
  Me.ListBox1.List = tbl
End Sub
 
Private Sub b_raz_Click()
  Me.TextBox1 = ""
End Sub
 
Private Sub ComboBox1_Click()
  Me.TextBox1 = Me.TextBox1 & " " & ComboBox1
End Sub
 
Private Sub B_result_Click()
  Set f2 = Sheets("résultat")
  f2.Cells.ClearContents
  a = Me.ListBox1.List
  f2.[A2].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
  c = 0
  For c = 1 To NbCol
     f2.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c)
  Next
  f2.Cells.EntireColumn.AutoFit
End Sub
 
Private Sub ComboBox1_Change()
 If Me.ComboBox1.ListIndex = -1 Then
   Me.ComboBox1.List = Filter(ChoixCombo, Me.ComboBox1.Text, True, vbTextCompare)
   Me.ComboBox1.DropDown
  Else
 
  End If
End Sub
Private Sub ListBox1_Click()
  enreg = Me.ListBox1.Column(NbCol) + Range(NomTableau).Row - 1
  Rows(enreg).Select
End Sub

Boisgontier

**boisgontierjacques** · 24/03/2020, 16h26

Version sans tableau

Code :

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

1
2
3
  Set f = Sheets("bd")        ' à adapter
  NomTableau = "Tableau1"
  Set Rng = f.Range("A2:H" & f.[A65000].End(xlUp).Row)          ' à adapter

Boisgontier

**Guizmonster** · 24/03/2020, 22h39

Bonsoir,

Cela fonctionne impeccablement et j'ai pu l'adapter sur mon fichier final.
Il me reste 2 questions. Est-il possible de s'affranchir des accents en plus des majuscules ?
J'ai trouvé ton code sur ça mais je n'arrive pas à l'intégrer.

Code :

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

1
2
3
4
5
6
7
8
9
10
Function sansAccent(chaine)
   codeA = "ÉÈÊËÔéèêëàçùôûïî"
   codeB = "EEEEOeeeeacuouii"
   temp = chaine
   For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
   Next
   sansAccent = temp
End Function

Est-il également possible de ne pas afficher certaines colonnes dans le formulaire de recherche car celles-ci n'apportent rien dans la recherche?

Merci pour tout.

**boisgontierjacques** · 25/03/2020, 08h31

Version sans accent.

Boisgontier

**Guizmonster** · 25/03/2020, 14h59

Merci cela fonctionne au poil.

Pour finir, est-il possible par exemple de ne pas prendre en compte la colonne C et la colonne D car les infos dedans n'apporte rien à la recherche et encombre le formulaire de recherche?

**boisgontierjacques** · 25/03/2020, 19h41

Bonsoir,

C'est un pgm générique
Il faudra adapter ColVisu=Array(1,2,5,6,7,8,9,10,11)

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
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
Option Compare Text
Dim TblBD(), Choix(), NomTableau, NbCol, ChoixCombo(), Rng, colVisu(), Ncol
Private Sub UserForm_Initialize()
  colVisu = Array(1, 2, 5, 6, 7, 8, 9, 10, 11)  ' à adapter
  NomTableau = "Tableau1"
  'Set Rng = Range(NomTableau)                          ' si tableau à adapter
  Set f = Sheets("BD")                                  ' si non tableau
  Set Rng = f.Range("A2:K" & f.[A65000].End(xlUp).Row)  ' si non tableau
  ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng
  Set Rng = Range(NomTableau)
  NbCol = Range(NomTableau).Columns.Count
  If UBound(colVisu) < 2 Then
     ReDim colVisu(0 To NbCol - 1): For i = 0 To NbCol - 1: colVisu(i) = i + 1: Next i
  End If
  Ncol = UBound(colVisu) + 1
  TblBD = Range(NomTableau).Resize(, NbCol + 1).Value
  For i = 1 To UBound(TblBD): TblBD(i, NbCol + 1) = i: Next i
  ReDim Choix(1 To UBound(TblBD))
  NbCol = Range(NomTableau).Columns.Count
  For i = LBound(TblBD) To UBound(TblBD)
     For Each k In colVisu
       Choix(i) = Choix(i) & sansAccent(TblBD(i, k)) & "|"
     Next k
     Choix(i) = Choix(i) & i  ' no ligne BD
  Next i
  '-- affichage initial
  Dim Tbl(): ReDim Tbl(1 To UBound(TblBD), 1 To Ncol + 1)
  For i = 1 To UBound(TblBD)
      c = 0
      For Each k In colVisu
        c = c + 1: Tbl(i, c) = TblBD(i, k)
      Next k
      Tbl(i, c + 1) = TblBD(i, NbCol + 1)
  Next i
  '--
  Me.ListBox1.List = Tbl
  EnTeteListBox
  ChoixCombo = ListeMotsTab(Range(NomTableau))
  Me.ComboBox1.List = ListeMotsTab(Range(NomTableau))
  Me.ComboTri.List = Application.Transpose(Range(NomTableau).Offset(-1).Resize(1))  ' Ordre tri
End Sub
 
Private Sub TextBox1_Change()
  If Me.TextBox1 <> "" Then
     mots = Split(sansAccent(Me.TextBox1), " ")
     Tbl = Choix
     For i = LBound(mots) To UBound(mots)
        Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
     n = UBound(Tbl) + 1
     If n > 0 Then
        Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To Ncol + 1)
        For i = LBound(Tbl) To UBound(Tbl)
          a = Split(Tbl(i), "|")
          For k = 1 To Ncol + 1: b(i + 1, k) = a(k - 1): Next k
        Next i
        Me.ListBox1.List = b
        Me.LabelCpt.Caption = UBound(Tbl) + 1 & " Ligne(s)"
     Else
       Me.ListBox1.Clear
     End If
  Else
     UserForm_Initialize
  End If
End Sub
 
Sub EnTeteListBox()
    NbCol = Range(NomTableau).Columns.Count
    x = Me.ListBox1.Left + 8
    Y = Me.ListBox1.Top - 12
    For Each c In colVisu
      Set Lab = Me.Controls.Add("Forms.Label.1")
      Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
      Lab.Top = Y
      Lab.Left = x
      Lab.Height = 16
      Lab.Width = Range(NomTableau).Columns(c).Width * 1#
      x = x + Int(Range(NomTableau).Columns(c).Width * 1)
      tempcol = tempcol & Int(Range(NomTableau).Columns(c).Width * 1#) & ";"
    Next
    tempcol = Left(tempcol, Len(tempcol) - 1)
    Me.ListBox1.ColumnCount = NbCol + 1
    Me.ListBox1.ColumnWidths = tempcol
End Sub
 
Private Sub ComboTri_click()
  Dim Tbl()
  colTri = Me.ComboTri.ListIndex
  Tbl = Me.ListBox1.List
  TriMultiCol Tbl, LBound(Tbl), UBound(Tbl), colTri
  Me.ListBox1.List = Tbl
End Sub
 
Private Sub b_raz_Click()
  Me.TextBox1 = ""
End Sub
 
Private Sub ComboBox1_Click()
  Me.TextBox1 = Me.TextBox1 & " " & ComboBox1
End Sub
 
Private Sub B_result_Click()
  Set f2 = Sheets("résultat")
  f2.Cells.ClearContents
  a = Me.ListBox1.List
  f2.[A2].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
  c = 0
  For c = 1 To NbCol
     f2.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c)
  Next
  f2.Cells.EntireColumn.AutoFit
End Sub
 
Private Sub ComboBox1_Change()
 If Me.ComboBox1.ListIndex = -1 Then
   Me.ComboBox1.List = Filter(ChoixCombo, Me.ComboBox1.Text, True, vbTextCompare)
   Me.ComboBox1.DropDown
  Else
 
  End If
End Sub
 
Private Sub ListBox1_Click()
  enreg = Me.ListBox1.Column(Ncol) + Range(NomTableau).Row - 1
  Rows(enreg).Select
End Sub
 
Sub TriMultiCol(a(), gauc, droi, colTri) ' Quick sort
  Dim colD, colF, ref, g, d, c, temp
  colD = LBound(a, 2): colF = UBound(a, 2)
  ref = a((gauc + droi) \ 2, colTri)
  g = gauc: d = droi
  Do
    Do While a(g, colTri) < ref: g = g + 1: Loop
    Do While ref < a(d, colTri): d = d - 1: Loop
    If g <= d Then
      For c = colD To colF
        temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
      Next
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then TriMultiCol a, g, droi, colTri
  If gauc < d Then TriMultiCol a, gauc, d, colTri
End Sub
 
Function sansAccent(chaine)
   codeA = "éèêëàâçùôûïîÉÈÊËÔ"
   codeB = "eeeeaacuouiiEEEEO"
   temp = chaine
   For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
   Next
   sansAccent = temp
End Function

Boisgontier

**Guizmonster** · 29/03/2020, 16h59

Merci c'est parfait!

**Pierre Fauconnier** · 13/04/2020, 16h56

Salut

Envoyé par boisgontierjacques

[...]

Code :

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

1
2
[...]
  Set Rng = f.Range("A2:K" & f.[A65000].End(xlUp).Row)  ' si non tableau

[...[

Ne JAMAIS utiliser une syntaxe telle que [A6500]...

D'abord, d'où sort ce 65000? En 2020, il y a 1048576 lignes. Les aficionados de cette syntaxe ne savent probablement pas ce qu'ils utilisent ni ce qu'ils mettent en place lorsqu'ils utilisent cette syntaxe "d'initié"... Ils n'ont en tout cas jamais été capables d'expliquer les avantages de leur syntaxe.

**Philippe Tulliez** · 13/04/2020, 17h48

Bonjour,
Je partage ce que Pierre a écrit à propos de cet adressage entre crochet.
Le pire c'est que ceux qui débutent et reçoivent une telle aide, vont trainer cette mauvaise habitude longtemps. C'est comme un virus, c'est dur de s'en débarrasser.

Moteur de recherche à l'aide de vba

Macros et VBA Excel

Discussions similaires

Partager

Partager