Discussion :

[vbanovice]

bonjour

je me permet de demander pour un ami qui fonctione sous excel 2007 d'adapter la macro suivante afin de la faire fonctionner sous excel 2007

voici la macro:

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
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

Cordialement.

Merci de vos aides

@+

[aalex_38]

Une recherche sur le forum ou sur google te montreras que FileSearch
n'existe plus, il faut soit faire autrement, soit utiliser une classe

[vbanovice]

merci mais etant tres novice en vba, la on peur dire que je "nage"
j'ai fait une recherche sur google et adapte un complement pour excel 2007 et vb sur filesearch
mais cela ne marche pas

cela bloque a la ligne Set FS = Application.FileSearch

merci d'apporter un peut d'aide
@+

[LeForestier]

Bonjour,
Ca pourra peut être t'aider
A+

[vbanovice]

merci mais comme je la disais meme avec le complement ca ne fonctione pas ou je n'ai pas adapter la macro correctement si il faliat la modifier

merci de m'aider

@+

[LeForestier]

Tu a bien ajouter la référence...
Microsoft Scripting Runtime
Edit: Ca bloque ??? Mais quel est le message d'erreur ?
Edit : Sorry, mais j'étais occupé sur un autre truc et j'ai mélanger les deux.
Dans les références c'est la ligne "ClFileSearch" que tu doit checker