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
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
| Option Explicit
Public Notepad$
Public Zip$
Public TOrg%(1 To 20)
Public LTOrg_max%
Public NomFichierDAT$
Public NomFichierZIP$
Public IDFichier$
Public PrefixeFichier$
Public DriveFichier$
Public RepertFichier$
Public DerniereLigne& ' Dernière ligne du fichier Excel contenant une donnée
Public DerniereColonne$
Dim Flag_Erreur As Boolean
Dim Cell As Variant
Dim Enreg$ ' Contenu d'un enregistrement en cours de copie
Dim Line As Variant ' Ligne Excel
Dim Pos% ' Position du . dans NomFichierDAT
Sub Formatage()
'
Initialisation
' Se positionner dans le répertoire du dernier fichier accédé
RepertFichier = Application.RecentFiles(1).Path
While Right(RepertFichier, 1) <> "\"
RepertFichier = Left(RepertFichier, Len(RepertFichier) - 1)
Wend
DriveFichier = Left(RepertFichier, 1)
ChDrive DriveFichier
ChDir (RepertFichier)
' Ouverture du fichier Excel contenant les données
Do
NomFichierDAT = Application.GetOpenFilename
If NomFichierDAT = "Faux" Then
'Application.Quit
ActiveWorkbook.Close
End If
Loop Until NomFichierDAT <> ""
Workbooks.Open Filename:=NomFichierDAT, ReadOnly:=True
' Le fichier est-il sur un autre lecteur
If InStr(1, NomFichierDAT, ":") <> 0 Then
DriveFichier = Left(NomFichierDAT, 1)
RepertFichier = NomFichierDAT
While Right(RepertFichier, 1) <> "\"
RepertFichier = Left(RepertFichier, Len(RepertFichier) - 1)
Wend
End If
' Suppression de la ligne d'entête
Rows("1:1").Select
Range("C1").Activate
Selection.Delete Shift:=xlUp
' Formatage selon le type de flux
If PrefixeFichier = "LVI" Then
Format_LVI
Else
Format_VRT
End If
' Ajout des préfixe et suffixe
NomFichierDAT = "00000_" & PrefixeFichier & IDFichier & "_" & Format(Date, "yymmdd") & ".dat"
' Sauvegarde au format fixe
Flag_Erreur = False
Open NomFichierDAT For Output As #1
For Each Line In Range("A1:" & DerniereColonne & DerniereLigne).Rows
Enreg = ""
For Each Cell In Line.Cells
'Contrôle selon le type de flux
If Left(PrefixeFichier, 3) = "LVI" Then
Ctrl_LVI
Enreg = Enreg & RPADLVI(Cell.Text)
Else
Ctrl_VRT
Enreg = Enreg & RPADVRT(Cell.Text)
End If
Next
Print #1, Enreg
Next
Close #1
' Fermeture du fichier Excel
ActiveWorkbook.Close SaveChanges:=False
If Flag_Erreur Then
' Écrasement du fichier en sortie
Kill NomFichierDAT
' Message de fin - Erreur
Enreg = MsgBox("Fichier " & NomFichierDAT & " non formatté", vbOKOnly + vbCritical _
, "Echec du formatage")
Else
' Suppression du dernier retour-chariot
BlocNote
' Compression du fichier
Winzip
If Flag_Erreur Then
' Message de fin - Erreur compression
Enreg = MsgBox("Fichier " & NomFichierDAT & " non compressé", vbOKOnly + vbCritical _
, "Echec de compression")
Else
' Message de fin - OK
Enreg = MsgBox("Fichier " & NomFichierZIP & " créé avec " & DerniereLigne & " enregistrement(s)", vbOKOnly + vbInformation _
, "Formatage réussi")
End If
End If
End Sub
Function RPADLVI(Text) As Variant
' Pour avoir les explications sur les longueurs des colonnes, se reporter au descriptif
' de l'enregistrement règlement 1 de LVI AUTO de l'organisation PRP
Select Case Cell.Column
Case 1 ' Id. d'enregistrement
RPADLVI = Left(Text, 1)
Case 2 ' Numéro mouvement
RPADLVI = Right(String(4, "0") & Text, 4)
Case 3, 9, 11, 13, 15, 17, 19, 21, 23 ' Montant
RPADLVI = Left(Text & Space(10), 10)
Case 4 ' Code devise
RPADLVI = Left(Text & Space(5), 5)
Case 5, 7 ' Numéro du règlement / commentaire
RPADLVI = Left(Text & Space(30), 30)
Case 6 ' Date de création
RPADLVI = Right(String(6, "0") & Text, 6)
Case 8, 10, 12, 14, 16, 18, 20, 22 ' Facture
RPADLVI = Left(Text & Space(20), 20)
End Select
End Function
Function RPADVRT(Text) As Variant
' Pour avoir les explications sur les longueurs des colonnes, se reporter au descriptif
' de l'enregistrement règlement 1 de VRTAUTOPAID de l'organisation MP
Select Case Cell.Column
Case 1 ' Id. d'enregistrement
RPADVRT = Left(Text, 1)
Case 2 ' Numéro mouvement
RPADVRT = Right(String(4, "0") & Text, 4)
Case 4, 11, 13, 15, 17, 19, 21, 23, 25 ' Montant
RPADVRT = Left(Text & Space(10), 10)
Case 3, 5 ' Code organisation / devise
RPADVRT = Left(Text & Space(5), 5)
Case 6, 8 ' Numéro du règlement / Client
RPADVRT = Left(Text & Space(30), 30)
Case 9 ' Commentaire
RPADVRT = Left(Text & Space(240), 240)
Case 7 ' Date de règlement
RPADVRT = Right(String(6, "0") & Text, 6)
Case 10, 12, 14, 16, 18, 20, 22, 24 ' Facture
RPADVRT = Left(Text & Space(20), 20)
End Select
End Function
Sub Format_LVI()
DerniereColonne = "U"
' Formatage de la date sur 6 chiffres
Columns("F:F").Select
Selection.NumberFormat = "000000"
' Formatage Nombre avec 0 décimales
If Range("A2").Value = "" Then
DerniereLigne = 1
Else
Selection.End(xlDown).Select
DerniereLigne = ActiveCell.Row
End If
Range("H1:" & DerniereColonne & DerniereLigne).Select
Selection.NumberFormat = "0"
Range("C1:C" & DerniereLigne).Select
Selection.NumberFormat = "0"
End Sub
Sub Format_VRT()
DerniereColonne = "Y"
' Formatage de la date sur 6 chiffres
Columns("G:G").Select
Selection.NumberFormat = "000000"
' Formatage Nombre avec 0 décimales
If Range("A2").Value = "" Then
DerniereLigne = 1
Else
Selection.End(xlDown).Select
DerniereLigne = ActiveCell.Row
End If
Range("J1:" & DerniereColonne & DerniereLigne).Select
Selection.NumberFormat = "0"
Range("D1:D" & DerniereLigne).Select
Selection.NumberFormat = "0"
End Sub
Sub Ctrl_VRT()
Dim l_sum&
Dim Ligne%
Dim Temp#
' Contrôle de l'identifiant de l'enregistrement
If Cell.Column = 1 Then
If Cell.Text <> 1 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". L'identifiant de l'enregistrement doit être 1 : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle du numéro de mouvement
If Cell.Column = 2 Then
If Cell.Row <> Abs(Cell.Text) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Numéro de mouvement incorrect : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle du code organisation
If Cell.Column = 3 Then
Ligne = 1
Do
If TOrg(Ligne) = Cell.Value Then
Exit Do
End If
Ligne = Ligne + 1
Loop Until Ligne > LTOrg_max
If Ligne > LTOrg_max Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le code organisation est incorrect : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle du montant du règlement
If Cell.Column = 4 Then
If Not IsNumeric(Cell.Value) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement n'est pas numérique : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
ElseIf IsEmpty(Cell.Value) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement n'est pas renseigné : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
Else
' if Cell.Value <> Int(Cell.Value) ne marche pas tout le temps ! Parfois Temp vaut qqchose * 10 puissane -9
Temp = Abs(Cell.Value - Int(Cell.Text))
If Temp > 0.01 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement ne doit pas avoir de décimales : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End If
' Contrôle du montant du règlement par rapport à la somme des montants lettrés
' J'ai remplacé Cell.Row par 1 dans Int(Line.Cells(1, 7).Value) car on dirait
' que l'on fait un déplacement relatif par rapport à la ligne en cours et non
' par rapport au haut de la feuille !?
If Cell.Column = 4 Then
For Ligne = 1 To 8
' Montant lettré non numérique
If Not IsNumeric(Line.Cells(1, 9 + (Ligne * 2))) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant lettré " & Ligne & " non numérique", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
Next Ligne
' Contrôle de la somme des montants lettrés
If Flag_Erreur = False Then
l_sum = Int(Line.Cells(1, 11).Value) _
+ Int(Line.Cells(1, 13).Value) _
+ Int(Line.Cells(1, 15).Value) _
+ Int(Line.Cells(1, 17).Value) _
+ Int(Line.Cells(1, 19).Value) _
+ Int(Line.Cells(1, 21).Value) _
+ Int(Line.Cells(1, 23).Value) _
+ Int(Line.Cells(1, 25).Value)
If Abs(Cell.Value) < l_sum Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant est inférieur à la somme des montants lettrés : " & l_sum, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End If
' Contrôle de la cohérence de présence des facture lettrées / montants lettrés
If Cell.Column = 4 Then
For Ligne = 1 To 8
' Montant lettré non renseigné mais numéro de facture renseigné
If IsEmpty(Line.Cells(1, 9 + (Ligne * 2))) _
And Not IsEmpty(Line.Cells(1, 8 + (Ligne * 2))) _
Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Montant lettré " & Ligne & " non renseigné", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
' Montant lettré renseigné mais numéro de facture non renseigné
If Not IsEmpty(Line.Cells(1, 9 + (Ligne * 2))) _
And IsEmpty(Line.Cells(1, 8 + (Ligne * 2))) _
Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Numéro de facture lettrée " & Ligne & " non renseigné", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
Next Ligne
End If
' Contrôle de la longueur du numéro de règlement
If Cell.Column = 6 Then
If Len(Cell.Text) > 30 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le numéro règlement fait plus de 30 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la date
If Cell.Column = 7 Then
If Right(String(6, "0") & Cell.Text, 6) > Format(Date, "yymmdd") Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". La date est supérieure à la date du jour : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la longueur du client
If Cell.Column = 8 Then
If Len(Cell.Text) > 40 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le client fait plus de 40 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la longueur du commentaire/référence de lettrage
If Cell.Column = 8 Then
If Len(Cell.Text) > 240 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le commentaire fait plus de 240 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End Sub
Sub Ctrl_LVI()
Dim l_sum&
Dim Ligne%
Dim Temp#
' Contrôle de l'identifiant de l'enregistrement
If Cell.Column = 1 Then
If Cell.Text <> 1 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". L'identifiant de l'enregistrement doit être 1 : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle du numéro de mouvement
If Cell.Column = 2 Then
If Cell.Row <> Abs(Cell.Text) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Numéro de mouvement incorrect : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle du montant du règlement
If Cell.Column = 3 Then
If Not IsNumeric(Cell.Value) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement n'est pas numérique : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
ElseIf IsEmpty(Cell.Value) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement n'est pas renseigné : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
Else
Temp = Abs(Cell.Value - Int(Cell.Value))
If Temp > 0.01 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant du règlement ne doit pas avoir de décimales : " & Cell.Value, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End If
' Contrôle du montant du règlement par rapport à la somme des montants lettrés
' J'ai remplacé Cell.Row par 1 dans Int(Line.Cells(1, 7).Value) car on dirait
' que l'on fait un déplacement relatif par rapport à la ligne en cours et non
' par rapport au haut de la feuille !?
If Cell.Column = 3 Then
For Ligne = 1 To 8
' Montant lettré non numérique
If Not IsNumeric(Line.Cells(1, 7 + (Ligne * 2))) Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Montant lettré " & Ligne & " non numérique", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
Next Ligne
' Contrôle de la somme des montants lettrés
If Flag_Erreur = False Then
l_sum = Int(Line.Cells(1, 9).Value) _
+ Int(Line.Cells(1, 11).Value) _
+ Int(Line.Cells(1, 13).Value) _
+ Int(Line.Cells(1, 15).Value) _
+ Int(Line.Cells(1, 17).Value) _
+ Int(Line.Cells(1, 19).Value) _
+ Int(Line.Cells(1, 21).Value) _
+ Int(Line.Cells(1, 23).Value)
If Abs(Cell.Value) < l_sum Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le montant est inférieur à la somme des montants lettrés : " & l_sum, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End If
' Contrôle de la cohérence de présence des facture lettrées / montants lettrés
If Cell.Column = 3 Then
For Ligne = 1 To 8
' Montant lettré non renseigné mais numéro de facture renseigné
If IsEmpty(Line.Cells(1, 9 + (Ligne * 2))) _
And Not IsEmpty(Line.Cells(1, 8 + (Ligne * 2))) _
Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Montant lettré " & Ligne & " non renseigné", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
' Montant lettré renseigné mais numéro de facture non renseigné
If Not IsEmpty(Line.Cells(1, 9 + (Ligne * 2))) _
And IsEmpty(Line.Cells(1, 8 + (Ligne * 2))) _
Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Numéro de facture lettrée " & Ligne & " non renseigné", vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
Next Ligne
End If
' Contrôle de la longueur de la devise
If Cell.Column = 4 Then
If Len(Cell.Text) > 5 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". La devise fait plus de 5 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la longueur du numéro de règlement
If Cell.Column = 5 Then
If Len(Cell.Text) > 30 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". Le numéro règlement fait plus de 30 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la date
If Cell.Column = 6 Then
If Right(String(6, "0") & Cell.Text, 6) > Format(Date, "yymmdd") Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". La date est supérieure à la date du jour : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
' Contrôle de la longueur du commentaire/référence de lettrage
If Cell.Column = 7 Then
If Len(Cell.Text) > 30 Then
Flag_Erreur = True
Enreg = MsgBox("Ligne " & Cell.Row & ". La référence LVI fait plus de 30 caractères : " & Cell.Text, vbOKOnly + vbExclamation _
, "Contrôle fichier")
End If
End If
End Sub
Sub Initialisation()
Dim Valeur%
Dim Ligne%
Notepad = ActiveWorkbook.Worksheets("Paramètre").Range("C1").Value
Zip = ActiveWorkbook.Worksheets("Paramètre").Range("C2").Value
Valeur = ActiveWorkbook.Worksheets("Paramètre").Range("A1").Value
Ligne = 1
While Valeur > 0
TOrg(Ligne) = Valeur
Ligne = Ligne + 1
Valeur = ActiveWorkbook.Worksheets("Paramètre").Range("A" & Ligne).Value
Wend
LTOrg_max = Ligne - 1
UserForm1.Show 'Active le userform
End Sub
Sub BlocNote()
Dim Temp$
' Nettoyage de NomFichierDat
While InStr(1, NomFichierDAT, "\") <> 0
NomFichierDAT = Right(NomFichierDAT, Len(NomFichierDAT) - InStr(1, NomFichierDAT, "\"))
Wend
' == Enlever la dernière ligne ===
Temp = Shell(Notepad & " " & NomFichierDAT, vbNormalFocus)
If ActiverAppli(NomFichierDAT) = False Then
Exit Sub
End If
'EDU - Correction d'une anomalie
'Utilisation du CTRL + END au lieu du DOWN pour se positionner à la fin du fichier
'car BUG du DOWN au bout de la 8175 ligne
'SendKeys "{DOWN " & DerniereLigne & "}", True ' Se positionner sur la dernière ligne + 1
SendKeys "^{END}", True
SendKeys "{BACKSPACE}", True ' Suppression dernière ligne vide
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "%FE", True ' Enregistrer
Pause 0.5
SendKeys "%FQ", True ' Quitter notepad.exe
End Sub
Sub Winzip()
Dim Temp$
NomFichierZIP = RepertFichier & "00000_" & PrefixeFichier & IDFichier & ".zip"
' == compresse le fichier
Temp = Shell(Zip & " -a """ & NomFichierZIP & """ """ & RepertFichier & NomFichierDAT & """")
If Temp = 0 Then
Flag_Erreur = True
Else
Application.Wait (Now + TimeValue("0:00:02"))
' Écrasement du fichier en sortie : on ne conserve que le zip
Kill RepertFichier & NomFichierDAT
End If
End Sub |
Répondre avec citation
Partager