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 |
faire fonctionner macro excel 2007
Répondre avec citation
merci pour ta réponse mais je doit la mettre a quel endroit de la macro le microsoft scripting runtine ?
Envoyé par LeForestier
Partager