imcompatibilité fonction 2003 et 2007

**isfet** · 11/05/2010, 10h06

Bonjour

on m'a demandé de corriger une macro afin de la faire fonctionner sous 2007, je m'en sors bien en programmation mais je ne connais pas les fonction VBA !

la ligne suivante me pose problème :

Code :

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

Filename = Application.FileSearch.FoundFiles(1)

pouvez vous m'aider ?

merci d'avance

**Didier Gonard** · 11/05/2010, 10h14

Bonjour,

incompatibilité connue

la solution peut dépendre du contexte, peux-tu nous mettre le module de code incriminé entre balise de code ?

les solutions existent...

cordialement,

Didier

Invité · 11/05/2010, 10h17

Bonjour

Un peu de lecture : Un complément FileSearch pour Excel 2007

Edit : Grillé par Ormonth

Philippe

**isfet** · 11/05/2010, 10h26

Le module est enorme, ce n'est pas mon code, on m'a envoyé cette macro ce matin pour la rendre compatible avec 2007

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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
Public Sub BEH_Data_Extraction_APES()
Dim LRarray(185)
Dim MNarray(185)
 
Application.ScreenUpdating = False
WBName = ActiveWorkbook.Name
 
'First clear the Datasheet Sheet
Windows(WBName).Activate
Sheets("DataSheet").Cells.Clear
 
'Make arrays for Librec
loopcount = 1
Do While Not IsEmpty(Range("RecordsToExtract").Cells(loopcount, 1))
    LRarray(loopcount) = Range("RecordsToExtract").Cells(loopcount, 1)
 
    'Format for 6 characters
    If Len(LRarray(loopcount)) = 5 Then LRarray(loopcount) = "0" & LRarray(loopcount)
 
    loopcount = loopcount + 1
 
Loop
 
'Remove one extra count from last loop before the While kicks out
LRSize = loopcount - 1
 
'Make arrays for Mnemonics
loopcount = 1
Do While Not IsEmpty(Range("MnemonicsToExtract").Cells(loopcount, 1))
    MNarray(loopcount) = Range("MnemonicsToExtract").Cells(loopcount, 1)
    loopcount = loopcount + 1
Loop
mnsize = loopcount - 1
 
'Bring Mnemonic names to DataSheet
Windows(WBName).Activate
Sheets("datasheet").Select
Range("A2") = "LibRec"
Range("B2") = "Run #"
Range("B2").Activate
 
For i = 1 To mnsize
    ActiveCell.Offset(0, i) = MNarray(i)
Next i
 
Range("B3").Select
 
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Please be patient..."
 
For i = 1 To LRSize
    'Find and open the data XLSS
    Application.StatusBar = "Searching for Activity " & LRarray(i) & ".xls"
    'First look for the data in the engineer's folder
    On Error Resume Next
    Err = 0
    With Application.FileSearch
        .NewSearch
        .LookIn = Range("UserFolder") & Range("WorkOrder")
        .SearchSubFolders = True
        .Filename = Range("UserInitials") & LRarray(i) & ".XLS"
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
    End With
    'Now try to set Filename
    'MsgBox "Found " & Application.FileSearch.FoundFiles.Count & " Files in " & Range("UserName")
    Filename = Application.FileSearch.FoundFiles(1)
 
 
    If Err <> 0 Then
        'Load SearchBox
        'SearchBox.Show
        'Process dies here and won't return without user closing the form
        'try to find a way to get the form to launch and let the macro continue operation
 
        Err = 0
        With Application.FileSearch
            .NewSearch
            .LookIn = Range("UserFolder")
            .SearchSubFolders = True
            .Filename = LRarray(i) & ".XLS"
 
 
            'try the ??? wildcard in the search
 
 
            .MatchTextExactly = True
            .FileType = msoFileTypeExcelWorkbooks
            .Execute
        End With
        'Unload SearchBox
 
    End If
 
 
    'Reset the error handler to normal
    On Error GoTo 0
 
    Filename = Application.FileSearch.FoundFiles(1)
 
    Workbooks.Open Filename, , ReadOnly = True
    Application.StatusBar = "Searching for Activity " & LRarray(i) & ".xls - Found"
 
    'Populate the Run Number column
    'Windows("JGL" & LRarray(i) & ".xls").Activate  '''go back and look up initials previous to this step; is this step needed?
    Columns("B:C").Select
 
 
    Selection.Find(What:="Ad_RunNumber_", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
 
 
 
 
    Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Select
 
        numcolumns = Selection.Columns.Count
 
        Columns("B:C").Select
        Selection.Find(What:="Ad_RunNumber_", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
 
 
 
 
    If ActiveCell.Column = 3 Then
    'Count the runs to protect for only 1 run in data as activecell positioning needs to be handled differently
       If IsEmpty(ActiveCell.Offset(0, 2)) Then
           runcount = 1
           ActiveCell.Offset(0, 1).Copy
       Else
           Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Copy
       End If
    ElseIf ActiveCell.Column = 2 Then
    'Count the runs to protect for only 1 run in data as activecell positioning needs to be handled differently
       If IsEmpty(ActiveCell.Offset(0, 3)) Then
           runcount = 1
           ActiveCell.Offset(0, 2).Copy
       Else
           Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 2).End(xlToRight)).Copy
       End If
    End If
    Windows(WBName).Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 
    'Populate the Librec column
    Do While Not (IsEmpty(ActiveCell))
     ActiveCell.Offset(0, -1) = LRarray(i)
     ActiveCell.Offset(1, 0).Activate
    Loop
    'Return Activecell to populate the actual mnemonics
    ActiveCell.Offset(0, 1).End(xlUp).Offset(1, -1).Activate
 
    'Find the mnemonics, cut and paste to Datasheet
    For j = 1 To mnsize
        Windows(Range("userinitials") & LRarray(i) & ".xls").Activate '''fix initial callout
        'Columns("A:B").Select
        'Used to select entire columns but when searching for ETS mnemonics (i.e. Focus Variables)
        'the search may fail in the data but find the mnemonic in the header and thus the macro
        'will not encounter error and set the cells to zero as intended.  This revised to only select the
        'region of the logsheet where data is present.
        Range("b1").Select
        Columns("b:c").Select
        On Error Resume Next
        Selection.Find(What:=MNarray(j), After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False).Activate
        If Err = 91 Then 'this means the data is not found in the sheet
            'Put Zero's in the field
            Windows(WBName).Activate
            Do While Not IsEmpty(ActiveCell)
                ActiveCell.Offset(0, 1) = 0
                ActiveCell.Offset(1, 0).Select
            Loop
            Err = 0
            'return activecell to the proper location
            ActiveCell.Offset(0, 2).End(xlUp).Offset(1, -1).Activate
        Else
            If ActiveCell.Column = 3 Then
 
                'check for logger data
                If Range(ActiveCell.Offset(0, numcolumns + 1), ActiveCell.Offset(0, numcolumns + 1)) = "" Then
                    Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Copy
 
                Else 'Search again
                    Selection.Find(What:=MNarray(j), After:=ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False).Activate
                    Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Copy
                End If
 
 
 
 
            ElseIf ActiveCell.Column = 2 Then
                Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 2).End(xlToRight)).Copy
            End If
 
            Windows(WBName).Activate
            ActiveCell.Offset(0, 1).Select
            Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
    Next j
    'position activecell for next Librec
    If runcount = 1 Then
        ActiveCell.End(xlToLeft).Offset(1, 1).Activate
    Else
        ActiveCell.End(xlToLeft).End(xlDown).Offset(1, 1).Activate
    End If
    loopcount = loopcount + 1
runcount = 0
Windows(Range("userinitials") & LRarray(i) & ".xls").Close
Next i
 
'Return the status bar to original
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
 
'This routine opens the library record on the BOTTOM of the list just extracted and uses the Mnemonic XX00 designation
'to search that document for the text description in the logsheet.  It then adds a line to the data page and brings the
'text over.
 
'Add a row to insert the names
Range("A3").EntireRow.Insert
 
 
On Error GoTo 0
Range("A2:B2").Cut
Range("A3:B3").Select
ActiveSheet.Paste
 
 
'''need to copy a2 through NumberOfChannels2
'Range("c2:au2").Copy  'temporarily added these three lines while debugging
Range("c2").Select
Range("c2", ActiveCell.Offset(0, 1).End(xlToRight)).Copy
 
Range("c3").Select
ActiveSheet.Paste
 
 
'Delete the top row to put cells in the proper location for the Tecplot
'naming routine to work properly
Range("A1").EntireRow.Delete
 
Range("B2").Select
 
 
'Close all of the Librec files
'For i = 1 To LRSize
'     Windows(Range("userinitials") & LRarray(i) & ".xls").Close '''fix initials'
'Next i
 
'Prompt user for Tecplot Formatting
If MsgBox("Format this data for Tecplot?", vbYesNo) = vbYes Then
    Call Format_for_Tecplot
Else  'Still want to give the option for renaming
    Call AutoRename
End If
 
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
 
Application.ScreenUpdating = True
 
End Sub

je m'attele à la lecture du tutoriel merci

**Didier Gonard** · 11/05/2010, 10h41

Bonjour,

je voulais dire la partie intéressante si extractible..

vois sur ce lien

où je voulais en venir, c'est que selon le contexte plusieurs approches peuvent exister.

Sion n'hésite pas à faire des recherches sur DVP avec les mots clefs, tu auras souvent des cas approchants bien solutionnés

cordialement,

Didier

**isfet** · 11/05/2010, 10h55

Merci pour le lien, j'ai commencé a le lire, je suis aussi en Stage de dut info ^^ et je dois corriger cette macro (le sujet de mon stage est d'en créer une) la macro corrigée sera exportée sur une 30n de postes ..

bye

edit : voici la partie de code qu'il me reste a corriger

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
 
For i = 1 To LRSize
    'Find and open the data XLSS
    Application.StatusBar = "Searching for Activity " & LRarray(i) & ".xls"
    'First look for the data in the engineer's folder
    On Error Resume Next
    Err = 0
    With Application.FileSearch
        .NewSearch
        .LookIn = Range("UserFolder") & Range("WorkOrder")
        .SearchSubFolders = True
        .Filename = Range("UserInitials") & LRarray(i) & ".XLS"
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
    End With
    'Now try to set Filename
    'MsgBox "Found " & Application.FileSearch.FoundFiles.Count & " Files in " & Range("UserName")
    Filename = Application.FileSearch.FoundFiles(1)
 
    'If Application.FileSearch.FoundFiles.Count > 0 Then
    '    For g = 1 To Application.FileSearch.FoundFiles.Count
    '        MsgBox Application.FileSearch.FoundFiles(g)
    '    Next g
    'End If
 
    'If it doesn't work then search all folders
 
    If Err <> 0 Then
        'Load SearchBox
        'SearchBox.Show
        'Process dies here and won't return without user closing the form
        'try to find a way to get the form to launch and let the macro continue operation
 
        Err = 0
        With Application.FileSearch
            .NewSearch
            .LookIn = Range("UserFolder")
            .SearchSubFolders = True
            .Filename = LRarray(i) & ".XLS"
 
 
            'try the ??? wildcard in the search
 
 
            .MatchTextExactly = True
            .FileType = msoFileTypeExcelWorkbooks
            .Execute
        End With
        'Unload SearchBox
 
    End If
 
    'MsgBox "Found " & Application.FileSearch.FoundFiles.Count & " Files in EngineerData"
 
    'If Application.FileSearch.FoundFiles.Count > 0 Then
    '    For g = 1 To Application.FileSearch.FoundFiles.Count
     '       MsgBox Application.FileSearch.FoundFiles(g)
    '    Next g
    'End If
 
 
    'Reset the error handler to normal
    On Error GoTo 0
 
    Filename = Application.FileSearch.FoundFiles(1)
 
    Workbooks.Open Filename, , ReadOnly = True
    Application.StatusBar = "Searching for Activity " & LRarray(i) & ".xls - Found"

imcompatibilité fonction 2003 et 2007 [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager