Problème dans l'appel de fonction personnalisée

**hichemnho** · 08/05/2014, 17h25

Bonjour,

J'ai une Macro qui appliquée à un fichier fonctionne parfaitement mais lorsque je l'appel par une autre macro dans le but de l'appliquer sur tout les fichiers d'un repertoire la colonne qui est censée être le resultat l'applcation de la fonction demeure vide.
La Macro "M" applique la "Macro6" sur tout les fichier du dossier "Dossier" qui contient 2 fichiers(juste pour tester en réalité il en contient plus) dont les cellule sont toutes de type
9,45,59,65664,0.283,-0.471

Voici le code des deux Macro "M" et 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
 
Sub M()
'
'
 
    FolderName = "C:\Users\SONY\Desktop\Dossier\"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.csv")
 
    'loop through the files
    Do While Len(Fname)
 
        With Workbooks.Open(FolderName & Fname)
 
           ' here comes the code for the operations on every file the code finds
 
           'HERE if you want to execute the second macro for every file in the loop
          Macro6
 
        End With
 
        ' go to the next file in the folder
        Fname = Dir
 
    Loop
 
End Sub

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
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
 
Sub Macro6()
'
' Macro6 Macro
'
 
'
    Columns("A:A").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("G:G").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=PERSONAL.XLSB!Changer()"
    ActiveCell.FormulaR1C1 = "=PERSONAL.XLSB!Changer(RC[-3])"
    Range("G1").Select
    Selection.AutoFill Destination:=Range("G1:G2"), Type:=xlFillDefault
    Range("G1:G2").Select
    Range("G2").Select
    Selection.AutoFill Destination:=Range("G2:G2560"), Type:=xlFillDefault
    Range("G2:G2560").Select
    Range("I2559").Select
    ActiveWindow.ScrollRow = 2533
    ActiveWindow.ScrollRow = 2528
    ActiveWindow.ScrollRow = 2506
    ActiveWindow.ScrollRow = 2479
    ActiveWindow.ScrollRow = 2447
    ActiveWindow.ScrollRow = 2415
    ActiveWindow.ScrollRow = 2384
    ActiveWindow.ScrollRow = 2357
    ActiveWindow.ScrollRow = 2316
    ActiveWindow.ScrollRow = 2284
    ActiveWindow.ScrollRow = 2253
    ActiveWindow.ScrollRow = 2221
    ActiveWindow.ScrollRow = 2189
    ActiveWindow.ScrollRow = 2149
    ActiveWindow.ScrollRow = 2117
    ActiveWindow.ScrollRow = 2072
    ActiveWindow.ScrollRow = 2027
    ActiveWindow.ScrollRow = 1981
    ActiveWindow.ScrollRow = 1927
    ActiveWindow.ScrollRow = 1855
    ActiveWindow.ScrollRow = 1782
    ActiveWindow.ScrollRow = 1715
    ActiveWindow.ScrollRow = 1656
    ActiveWindow.ScrollRow = 1602
    ActiveWindow.ScrollRow = 1552
    ActiveWindow.ScrollRow = 1502
    ActiveWindow.ScrollRow = 1448
    ActiveWindow.ScrollRow = 1394
    ActiveWindow.ScrollRow = 1330
    ActiveWindow.ScrollRow = 1276
    ActiveWindow.ScrollRow = 1235
    ActiveWindow.ScrollRow = 1190
    ActiveWindow.ScrollRow = 1149
    ActiveWindow.ScrollRow = 1100
    ActiveWindow.ScrollRow = 1041
    ActiveWindow.ScrollRow = 991
    ActiveWindow.ScrollRow = 951
    ActiveWindow.ScrollRow = 910
    ActiveWindow.ScrollRow = 874
    ActiveWindow.ScrollRow = 842
    ActiveWindow.ScrollRow = 806
    ActiveWindow.ScrollRow = 770
    ActiveWindow.ScrollRow = 733
    ActiveWindow.ScrollRow = 702
    ActiveWindow.ScrollRow = 670
    ActiveWindow.ScrollRow = 639
    ActiveWindow.ScrollRow = 602
    ActiveWindow.ScrollRow = 557
    ActiveWindow.ScrollRow = 516
    ActiveWindow.ScrollRow = 471
    ActiveWindow.ScrollRow = 440
    ActiveWindow.ScrollRow = 412
    ActiveWindow.ScrollRow = 376
    ActiveWindow.ScrollRow = 345
    ActiveWindow.ScrollRow = 313
    ActiveWindow.ScrollRow = 290
    ActiveWindow.ScrollRow = 263
    ActiveWindow.ScrollRow = 236
    ActiveWindow.ScrollRow = 214
    ActiveWindow.ScrollRow = 182
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 119
    ActiveWindow.ScrollRow = 96
    ActiveWindow.ScrollRow = 73
    ActiveWindow.ScrollRow = 55
    ActiveWindow.ScrollRow = 37
    ActiveWindow.ScrollRow = 24
    ActiveWindow.ScrollRow = 15
    ActiveWindow.ScrollRow = 1
    Columns("G:G").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("G:G").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=-6
    Columns("D:D").Select
    Selection.Copy
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 15
    ActiveWindow.ScrollRow = 33
    ActiveWindow.ScrollRow = 60
    ActiveWindow.ScrollRow = 82
    ActiveWindow.ScrollRow = 114
    ActiveWindow.ScrollRow = 141
    ActiveWindow.ScrollRow = 213
    ActiveWindow.ScrollRow = 259
    ActiveWindow.ScrollRow = 335
    ActiveWindow.ScrollRow = 367
    ActiveWindow.ScrollRow = 403
    ActiveWindow.ScrollRow = 435
    ActiveWindow.ScrollRow = 466
    ActiveWindow.ScrollRow = 502
    ActiveWindow.ScrollRow = 534
    ActiveWindow.ScrollRow = 575
    ActiveWindow.ScrollRow = 611
    ActiveWindow.ScrollRow = 643
    ActiveWindow.ScrollRow = 679
    ActiveWindow.ScrollRow = 715
    ActiveWindow.ScrollRow = 765
    ActiveWindow.ScrollRow = 814
    ActiveWindow.ScrollRow = 864
    ActiveWindow.ScrollRow = 918
    ActiveWindow.ScrollRow = 977
    ActiveWindow.ScrollRow = 1031
    ActiveWindow.ScrollRow = 1094
    ActiveWindow.ScrollRow = 1153
    ActiveWindow.ScrollRow = 1207
    ActiveWindow.ScrollRow = 1266
    ActiveWindow.ScrollRow = 1320
    ActiveWindow.ScrollRow = 1370
    ActiveWindow.ScrollRow = 1420
    ActiveWindow.ScrollRow = 1469
    ActiveWindow.ScrollRow = 1514
    ActiveWindow.ScrollRow = 1551
    ActiveWindow.ScrollRow = 1582
    ActiveWindow.ScrollRow = 1614
    ActiveWindow.ScrollRow = 1646
    ActiveWindow.ScrollRow = 1677
    ActiveWindow.ScrollRow = 1713
    ActiveWindow.ScrollRow = 1749
    ActiveWindow.ScrollRow = 1781
    ActiveWindow.ScrollRow = 1822
    ActiveWindow.ScrollRow = 1853
    ActiveWindow.ScrollRow = 1885
    ActiveWindow.ScrollRow = 1926
    ActiveWindow.ScrollRow = 1962
    ActiveWindow.ScrollRow = 1993
    ActiveWindow.ScrollRow = 2025
    ActiveWindow.ScrollRow = 2052
    ActiveWindow.ScrollRow = 2084
    ActiveWindow.ScrollRow = 2120
    ActiveWindow.ScrollRow = 2152
    ActiveWindow.ScrollRow = 2174
    ActiveWindow.ScrollRow = 2201
    ActiveWindow.ScrollRow = 2228
    ActiveWindow.ScrollRow = 2246
    ActiveWindow.ScrollRow = 2273
    ActiveWindow.ScrollRow = 2305
    ActiveWindow.ScrollRow = 2337
    ActiveWindow.ScrollRow = 2373
    ActiveWindow.ScrollRow = 2405
    ActiveWindow.ScrollRow = 2445
    ActiveWindow.ScrollRow = 2477
    ActiveWindow.ScrollRow = 2508
    ActiveWindow.ScrollRow = 2531
    ActiveWindow.ScrollRow = 2526
    ActiveWindow.ScrollRow = 2504
    ActiveWindow.ScrollRow = 2472
    ActiveWindow.ScrollRow = 2436
    ActiveWindow.ScrollRow = 2409
    ActiveWindow.ScrollRow = 2382
    ActiveWindow.ScrollRow = 2355
    ActiveWindow.ScrollRow = 2323
    ActiveWindow.ScrollRow = 2292
    ActiveWindow.ScrollRow = 2251
    ActiveWindow.ScrollRow = 2197
    ActiveWindow.ScrollRow = 2120
    ActiveWindow.ScrollRow = 2043
    ActiveWindow.ScrollRow = 1948
    ActiveWindow.ScrollRow = 1840
    ActiveWindow.ScrollRow = 1686
    ActiveWindow.ScrollRow = 1546
    ActiveWindow.ScrollRow = 1406
    ActiveWindow.ScrollRow = 1280
    ActiveWindow.ScrollRow = 1194
    ActiveWindow.ScrollRow = 1067
    ActiveWindow.ScrollRow = 959
    ActiveWindow.ScrollRow = 850
    ActiveWindow.ScrollRow = 742
    ActiveWindow.ScrollRow = 624
    ActiveWindow.ScrollRow = 516
    ActiveWindow.ScrollRow = 403
    ActiveWindow.ScrollRow = 249
    ActiveWindow.ScrollRow = 109
    ActiveWindow.ScrollRow = 1
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
    Range("A1").Select
    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.FormulaR1C1 = "Att1"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Att2"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Att3"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Att4"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Att5"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Att6"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Class"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "0"
    Selection.AutoFill Destination:=Range("G2:G2561"), Type:=xlFillDefault
    Range("G2:G2561").Select
    ActiveWindow.SmallScroll Down:=-24
    ActiveWindow.ScrollRow = 2505
    ActiveWindow.ScrollRow = 2496
    ActiveWindow.ScrollRow = 2487
    ActiveWindow.ScrollRow = 2478
    ActiveWindow.ScrollRow = 2460
    ActiveWindow.ScrollRow = 2442
    ActiveWindow.ScrollRow = 2424
    ActiveWindow.ScrollRow = 2401
    ActiveWindow.ScrollRow = 2378
    ActiveWindow.ScrollRow = 2347
    ActiveWindow.ScrollRow = 2301
    ActiveWindow.ScrollRow = 2256
    ActiveWindow.ScrollRow = 2207
    ActiveWindow.ScrollRow = 2130
    ActiveWindow.ScrollRow = 2044
    ActiveWindow.ScrollRow = 1976
    ActiveWindow.ScrollRow = 1917
    ActiveWindow.ScrollRow = 1850
    ActiveWindow.ScrollRow = 1782
    ActiveWindow.ScrollRow = 1687
    ActiveWindow.ScrollRow = 1596
    ActiveWindow.ScrollRow = 1506
    ActiveWindow.ScrollRow = 1411
    ActiveWindow.ScrollRow = 1325
    ActiveWindow.ScrollRow = 1244
    ActiveWindow.ScrollRow = 1172
    ActiveWindow.ScrollRow = 1072
    ActiveWindow.ScrollRow = 986
    ActiveWindow.ScrollRow = 923
    ActiveWindow.ScrollRow = 864
    ActiveWindow.ScrollRow = 805
    ActiveWindow.ScrollRow = 756
    ActiveWindow.ScrollRow = 706
    ActiveWindow.ScrollRow = 661
    ActiveWindow.ScrollRow = 620
    ActiveWindow.ScrollRow = 575
    ActiveWindow.ScrollRow = 539
    ActiveWindow.ScrollRow = 498
    ActiveWindow.ScrollRow = 462
    ActiveWindow.ScrollRow = 381
    ActiveWindow.ScrollRow = 349
    ActiveWindow.ScrollRow = 322
    ActiveWindow.ScrollRow = 295
    ActiveWindow.ScrollRow = 277
    ActiveWindow.ScrollRow = 250
    ActiveWindow.ScrollRow = 232
    ActiveWindow.ScrollRow = 218
    ActiveWindow.ScrollRow = 204
    ActiveWindow.ScrollRow = 191
    ActiveWindow.ScrollRow = 177
    ActiveWindow.ScrollRow = 164
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 137
    ActiveWindow.ScrollRow = 114
    ActiveWindow.ScrollRow = 96
    ActiveWindow.ScrollRow = 78
    ActiveWindow.ScrollRow = 60
    ActiveWindow.ScrollRow = 42
    ActiveWindow.ScrollRow = 19
    ActiveWindow.ScrollRow = 1
End Sub

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
 
Public Function Changer(ByVal CelluleEtudiee As Range) As Variant
 
Dim ValeurPartielle As Variant
Dim ValeurCellule As Variant
Dim I As Long
Dim PresenceE As Boolean
 
        ' Recherche caractère e
        Changer = ""
        ValeurCellule = ""
        PresenceE = False
        For I = 1 To Len(CelluleEtudiee)
            Select Case Mid(CelluleEtudiee, I, 1)
                   Case ","
                        If PresenceE = True Then
                           ValeurCellule = ValeurCellule & Val(ValeurPartielle) & ","
                           PresenceE = False
                        Else
                           ValeurCellule = ValeurCellule & ValeurPartielle & ","
                        End If
                        ValeurPartielle = ""
                   Case "e"
                        PresenceE = True
                        ValeurPartielle = ValeurPartielle & Mid(CelluleEtudiee, I, 1)
                   Case Else
                        ValeurPartielle = ValeurPartielle & Mid(CelluleEtudiee, I, 1)
            End Select
        Next I
 
        If PresenceE = True Then
           Changer = ValeurCellule & Val(ValeurPartielle)
        Else
           Changer = ValeurCellule & ValeurPartielle
        End If
 
End Function

Le soucis est dans l'appel de la fonction changer mais je n'arrive pas à le regler.

J'éspère que quelqu'un peut m'aider.

Je vous remercie énormement pour votre temps et votre attention et votre patience.

**mercatog** · 08/05/2014, 18h40

Codes dans un module standard

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
Option Explicit
 
Sub M()
Dim FolderName As String, FName As String
Dim Wbk As Workbook
 
Application.ScreenUpdating = False
FolderName = "C:\Users\SONY\Desktop\Dossier\"
 
FName = Dir(FolderName & "*.csv")
Do While Len(FName)
    Set Wbk = Workbooks.Open(FolderName & FName)
    Macro6 Wbk
    Wbk.Close True
    Set Wbk = Nothing
    FName = Dir
Loop
End Sub
 
Private Sub Macro6(ByVal Wbk As Workbook)
Dim LastLig As Long
 
With Wbk.Worksheets(1)
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
 
    With .Range("G1:G" & LastLig)
        .FormulaR1C1 = "='" & ThisWorkbook.Name & "'!CHANGER(RC[-6])"
        .Value = .Value
    End With
 
    .Range("G1:G" & LastLig).Cut .Range("A1")
    .Range("A1:A" & LastLig).TextToColumns Destination:=.Range("A1"), _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
 
    .Rows(1).Insert
    .Range("A1:G1").Value = Array("Att1", "Att2", "Att3", "Att4", "Att5", "Att6", "Class")
    .Range("G2:G" & LastLig) = 0
End With
End Sub
 
Private Function CHANGER(ByVal CelluleEtudiee As Range) As String
Dim ValeurCellule, ValeurPartielle
Dim PresenceE As Boolean
Dim i As Long
 
For i = 1 To Len(CelluleEtudiee)
    Select Case Mid(CelluleEtudiee, i, 1)
    Case ","
        If PresenceE Then
            ValeurCellule = ValeurCellule & Val(ValeurPartielle) & ","
            PresenceE = False
        Else
            ValeurCellule = ValeurCellule & ValeurPartielle & ","
        End If
        ValeurPartielle = ""
    Case "e"
        PresenceE = True
        ValeurPartielle = ValeurPartielle & Mid(CelluleEtudiee, i, 1)
    Case Else
        ValeurPartielle = ValeurPartielle & Mid(CelluleEtudiee, i, 1)
    End Select
Next i
 
If PresenceE Then
    CHANGER = ValeurCellule & Val(ValeurPartielle)
Else
    CHANGER = ValeurCellule & ValeurPartielle
End If
End Function

Problème dans l'appel de fonction personnalisée

Macros et VBA Excel

Discussions similaires

Partager

Partager