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
| '############################################
'# Ajouter impérativement la référence #
'# suivante dans Menu Outils/Références #
'# #
'# Microsoft Forms 2.0 Object Library #
'# C:\WINDOWS\system32\FM20.DLL #
'############################################
'### Constantes à adapter ###
Const AFFICHER_DANS_LISTBOX As Boolean = True 'True si on veut afficher le résultat dans une ListBox
Const AFFICHER_DANS_FEUILLE As Boolean = False 'True si on veut afficher le résultat dans une nouvelle feuille
'############################
Const LARGEUR_UF As Double = 320
Const HAUTEUR_UF As Double = 240
Const MARGE_UF As Double = 20
Public DataListBox As Variant
Sub RechercheDansClasseurs_2()
Dim FS As FileSearch
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim Recherche
Dim var
Dim i&
Dim k&
Dim cpt&
Dim A$
Dim T()
Dim bool As Boolean
Recherche = Application.InputBox( _
prompt:="Tapez le mot recherché.", _
Title:="Recherche dans les classeurs des clients", _
Type:=2)
If Recherche = False Then Exit Sub
Set FS = Application.FileSearch
FS.NewSearch
FS.LookIn = ThisWorkbook.Path
FS.FileType = msoFileTypeExcelWorkbooks
If FS.Execute() = 0 Then Exit Sub
'--- Si classeur déjà ouvert, on sort ---
On Error Resume Next
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Err.Clear
A$ = Mid(FS.FoundFiles(i&), InStrRev(FS.FoundFiles(i&), "\") + 1)
Set WB = Workbooks(A$)
If Err = 0 Then
MsgBox "Le classeur ''" & A$ & "'' est ouvert. Veuillez le fermer."
Exit Sub
End If
End If
Next i&
On Error GoTo 0
'--- Recherche dans les classeurs ---
Application.ScreenUpdating = False
For i& = 1 To FS.FoundFiles.Count
If FS.FoundFiles(i&) <> ThisWorkbook.FullName Then
Set WB = GetObject(FS.FoundFiles(i&))
Set S = WB.Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[f65536].End(xlUp).Row, 7))
var = R
For k& = 1 To UBound(var, 1)
If Trim(LCase(var(k&, 6))) = Trim(LCase(Recherche)) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 3, 1 To cpt&)
T(1, cpt&) = WB.Name
T(2, cpt&) = var(3, 3)
T(3, cpt&) = Recherche
End If
Next k&
WB.Close False
Set WB = Nothing
End If
Next i&
Set FS = Nothing
If cpt& = 0 Then
MsgBox "Aucune occurence du mot ''" & Recherche & "'' n'a été trouvé."
Application.ScreenUpdating = True
Exit Sub
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° Inscription du résultat dans une nouvelle feuille °°°
If AFFICHER_DANS_FEUILLE Then
Set WB = ThisWorkbook
Set S = WB.Sheets.Add(after:=WB.Sheets(WB.Sheets.Count))
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.Transpose(T)
Set R = S.Range("a1:c1")
R = Array("CLASSEUR", "CLIENT", "MOT RECHERCHE")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 35
S.Cells.Columns.AutoFit
End If
'°°° Inscription du résultat dans un UserForm ListBox °°°
If AFFICHER_DANS_LISTBOX Then
DataListBox = Application.Transpose(T)
bool = UserForm_aLaVolee
Application.ScreenUpdating = True
End If
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Application.ScreenUpdating = True
End Sub
Private Function UserForm_aLaVolee() As Boolean
Dim UF As Object
Dim LB As MSForms.ListBox
Dim CB As MSForms.CommandButton
Dim A$
Dim nbCol&
Dim i&
On Error GoTo Erreur
'--- Crée dynamiquement un UserForm ---
Set UF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UF
.Properties("Caption") = "Mots trouvés"
.Properties("Height") = HAUTEUR_UF
.Properties("Width") = LARGEUR_UF
End With
'--- Crée le bouton de fermeture ---
Set CB = UF.Designer.Controls.Add("forms.CommandButton.1")
With CB
.Caption = "Fermer"
.Left = (LARGEUR_UF - CB.Width) / 2
.Top = HAUTEUR_UF - (3 * MARGE_UF)
End With
'--- Crée la ListBox ---
Set LB = UF.Designer.Controls.Add("forms.ListBox.1")
With LB
nbCol& = UBound(DataListBox, 2)
.Left = MARGE_UF
.Top = MARGE_UF
.Height = CB.Top - (2 * MARGE_UF)
.Width = LARGEUR_UF - (2 * MARGE_UF)
.ColumnCount = nbCol&
.BoundColumn = 1
'°°° Calcul de ColumnWidths °°°
For i& = 1 To nbCol&
A$ = A$ & (.Width - nbCol&) \ nbCol& & ";"
Next i&
.ColumnWidths = Mid(A$, 1, Len(A$) - 1)
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
.BackColor = &HC0E0FF
.BorderStyle = fmBorderStyleSingle
End With
'°°° Ajout du code évènementiel °°°
A$ = "Sub CommandButton1_Click()" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub" & _
vbCrLf & "Sub UserForm_Initialize()" & _
vbCrLf & "ListBox1.List=DataListBox" & _
vbCrLf & "End Sub"
With UF.codemodule
i& = .CountOfLines
.insertlines i& + 1, A$
End With
'--- Affiche le UserForm ---
VBA.UserForms.Add(UF.Name).Show
'--- Détruit le UserForm ---
Erreur:
If Not UF Is Nothing Then ThisWorkbook.VBProject.VBComponents.Remove UF
If Err <> 0 Then UserForm_aLaVolee = True
End Function |