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
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
| Option Explicit
'--------------------------------------------------------------------------------------------------------------------------------------
'declaration for ThisWorkbook and the Workbook create
Public ClasseurPrincipale As Workbook
Public Classeur2 As Workbook
'declaration of variable for .dat
Public ObjShell, ObjFolder
Public Chemin
Public NomFichier As Variant, Nomtypefichier As Variant
Public NomChargement As Variant, NomTest As Variant
Public extension As Variant
'declaration for function "FichierExiste"
Public MonFichier As String
'declaration of variable for creation of Workbook
Public xlApp As Excel.Application
Public xlSheet As Excel.Worksheet
Public xlBook As Excel.Workbook
'declaration of Sheets/Charts
Dim Ws1 As Chart, Ws2 As Chart, Ws3 As Chart, Ws4 As Chart
Dim Ws5 As Worksheet, Ws6 As Worksheet
Dim Ws7 As Worksheet, Ws8 As Worksheet, Ws9 As Worksheet, Ws10 As Worksheet, Ws11 As Worksheet, Ws12 As Worksheet
'Controle présence feuille
Public Function FeuilleExiste(NomFeuille As String) As Boolean
On Error GoTo Err_FeuilleExiste
FeuilleExiste = False
FeuilleExiste = Not ActiveWorkbook.Worksheets(NomFeuille) Is Nothing
Err_FeuilleExiste:
End Function
Function CompterFichier(ByVal Doc As String) As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
CompterFichier = FSO.GetFolder(Doc).Files.Count
Set FSO = Nothing
End Function
'Macro pour identification de chaque feuilles et Graphs
Sub Initialization()
On Error Resume Next
Set Ws1 = Charts("Suivi couple direct")
Set Ws2 = Charts("Suivi angle direct")
Set Ws3 = Charts("Suivi couple rétro")
Set Ws4 = Charts("Suivi angle rétro")
Set Ws5 = Sheets("data")
Set Ws6 = Sheets("register1")
Set Ws7 = Sheets("1")
Set Ws8 = Sheets("2")
Set Ws9 = Sheets("3")
Set Ws10 = Sheets("result-1")
Set Ws11 = Sheets("result-2")
Set Ws12 = Sheets("result-3")
End Sub
'Macro Principale Scelta rapida da tastiera: CTRL + H
Sub D5()
Application.ScreenUpdating = False
'***************************************************************************************************************************************
'***************************************************************************************************************************************
'Cette macro à pour but de :
' - Venir charger les valeurs des fichier .dat, dans un fichier Excel portant le meme nom que le test :
' * En venant créer un dossier là où se trouve les données .dat.
' * Créer un fichier Excel comprenant toutes les données des fichier .dat avec une mise en forme qui puisse etre lu par Excel
' c'est à dire :
' * Suppression des espaces inutiles,
' * Remplacement des "." par des ",",
' * Séparation du Couple, Angle et Segment en trois colonnes distinctes.
'
' - Grace à une InputBox il est possible de choisir plusieurs fichiers .dat,(8 Maximum) :
' * En fonction de ce choix, la feuille comportera directement les noms des essais.
' * Avant de continuer la macro va effectivement compter le nombre de fichier présent dans le dossier sélectionner,
' + Si il n'y a pas le nombre indiqué, alors retour sur le choix du nombre de dossier ou sur le choix du dossier,
' + Sinon tout va bien et la macro peut continuer.
'
' - Cette macro va copier les valeur du classeur 2 dans les feuilles appropriés du classeur Source :
' * Lors de cette copie, suivant le nombre de données alors la macro va coller à divers endroit
' Si ligne >60000 alors on copie pour aller sur la feuille "... (2)", etc...
' * Concernant les valeurs de "50_tir" et "50_ril", elles sont collé directement dans la feuille 3
'***************************************************************************************************************************************
'***************************************************************************************************************************************
Dim StartTime As Double
'barre d'information
Application.DisplayAlerts = False
Application.DisplayStatusBar = True
StartTime = Timer
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Call Initialization 'Initialise les feuilles de ce classeur
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim extension As Variant 'ceci est la particule qui va permettre de définir le fichier à prendre ou à traiter
Dim derligne As Long 'cette variable permet de déterminer le nombre totale de ligne
Dim a As Integer 'variable pour boucle sur nombre de fichier à charger
Dim sheet As Integer 'variable utilisé pour fonction clearsheet
Dim b As Long, c As Long 'variable utilisé pour traitement information fichier.dat
Dim d As Integer, e As Integer 'variable utilisé pour traitement information fichier.dat
Dim f As Long, g As Long 'variable utilisé pour traitement information fichier.dat
Dim h As Integer 'variable utilisé pour copie entre les fichiers
Dim x 'variable booleene pour condition
Dim NombredeFichier As Integer 'variable pour connaitre le nombre de fichier à charger
Dim NombredeFeuille As Integer 'variable utilisé pour connaitre le nombre de feuille à insérer dans le Classeur2
Dim shFeuille As Worksheet 'variable pour vérification feuilles vides
Dim MinutesElapsed As String 'variable pour connaitre le temps de processus de la macro
'*************************************************************************************************************************************
'initialisation des variables
Set ClasseurPrincipale = ThisWorkbook
sheet = 1
'1)_GET THE DATA FROM THE FILE
'Appel de cette macro pour vérifier l'état de la feuille "register1"
clearcreatesheet name:="register1", clear:=1
' ----- ask in what folder to seek data
Do
Load Interface1 'charger l'userform
Interface1.Show 'montrer l'userform
Select Case Ws6.Range("A1").Value
Case 1 ' put 1 in range("a1") if "S:\R & D\Banchi prova\Report\ENGLISH" button is chosen
Set ObjShell = CreateObject("Shell.Application")
Set ObjFolder = ObjShell.BrowseForFolder(&H0&, "Selezione di una cartella", &H1&, "S:\R & D\Banchi prova\Report\ENGLISH")
On Error Resume Next
If ObjFolder = "Nothing" Then
Ws6.Range("A1").Value = 4 ' put 4 in range("a1") if no button is chosen
End If
Case 2 ' put 2 in range("a1") if "Selezione di una cartella" button is chosen
Set ObjShell = CreateObject("Shell.Application")
Set ObjFolder = ObjShell.BrowseForFolder(&H0&, "Selezione di una cartella", &H1&)
On Error Resume Next
If ObjFolder = "Nothing" Then
Ws6.Range("A1").Value = 4 ' put 4 in range("a1") if no button is chosen
End If
End Select
Loop While (Ws6.Range("A1").Value = 4) ' as long as no button is chosen keep looping
If (Ws6.Range("A1").Value = 1) Or (Ws6.Range("A1").Value = 2) Then 'if button 1 or 2 chosen
Chemin = ObjFolder.ParentFolder.ParseName(ObjFolder.Title).Path & "" 'register chosen adress in "Chemin"
ChDir Chemin 'set this directory as default
Erreur_nombre_fichier:
NombredeFichier = InputBox("Quale è il numero di file a caricare?", "Dare il numero del file ...")
If NomFichier = "Falso" Then Exit Sub
'compter le nombre de document dispo
If NombredeFichier > 8 Or NombredeFichier = 0 Then
MsgBox ("Deve rivedere il numero di file da utilizzare"), vbCritical
GoTo Erreur_nombre_fichier
End If
'A REVOIR-------------------------------
If NombredeFichier > 0 And NombredeFichier < 8 Then
If CompterFichier(Chemin) <> NombredeFichier Then
MsgBox ("C'è non lo stesso numero di file che questo presente nel cartella"), vbInformation
GoTo Erreur_nombre_fichier
End If
End If
'****************************************************************************************************************************************
For a = 1 To NombredeFichier '8 fichiers .dat maxi à charger
Erreur_type_fichier:
NomFichier = Application.GetOpenFilename("DAT Files (*.dat),*.dat") 'register name of the file
'****************************************************************************************************************************************
'Vérification du fichier à employer
If NomFichier = "Falso" Then 'if name uncorrect, cancel
MsgBox "Azione anullata", vbCritical
GoTo Stage2
Else
' check if file is TIR or RIL
Nomtypefichier = Right(NomFichier, 7)
extension = Right(NomFichier, 10)
'****************************************************************************************************************************************
' ----- check sheet called "a" create or clear
clearcreatesheet name:=Right(Str(a), 1), clear:=sheet
NomChargement = Mid(NomFichier, Len(Chemin) + 2)
NomTest = Mid(NomChargement, 1, Len(NomChargement) - 11)
If a = 1 Then 'Si a=1 alors différents, car il faut créer ou non le dossier avec le fichier Excel
If Not Nomtypefichier = "tir.dat" Then
'obligation de charger un tir en premier
MsgBox ("Si prega di selezionare un tipo di file .tir"), vbInformation
GoTo Erreur_type_fichier
End If
'On créer l'objet Excel
Set xlApp = CreateObject("Excel.Application")
'On ajoute un classeur
Set xlBook = xlApp.Workbooks.Add
'On défini le nombre d'onglets
NombredeFeuille = Application.RoundUp((NombredeFichier * 1.6), 1)
xlApp.SheetsInNewWorkbook = NombredeFeuille
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'APPELER MACRO EXTERNE POUR LIBERER DE L'ESPACE ET DU TEMPS DE PROCESS
Call Créer_Dossier
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Fermer le classeur
xlBook.Close False
'Réouvrir le fichier
Application.Workbooks.Open Chemin & "\" & NomTest & "\" & NomTest & ".xls"
'initialisation du classeur
Set Classeur2 = Workbooks(NomTest & ".xls")
'On rend le classeur visible
Classeur2.Visible = True
'Création des feuilles et nomination des feuilles
Classeur2.Worksheets(1).name = "80_tir"
Classeur2.Worksheets(2).name = "80_tir (2)"
Classeur2.Worksheets(3).name = "80_ril"
Classeur2.Worksheets(4).name = "80_ril (2)"
Classeur2.Worksheets(5).name = "50_tir"
Classeur2.Worksheets(6).name = "50_tir (2)"
Classeur2.Worksheets(7).name = "50_ril"
Classeur2.Worksheets(8).name = "50_ril (2)"
'Activation du classeur qui va recevoir les données
Classeur2.Sheets("80000 tir").Activate
' ----- import data
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & NomFichier, Destination:=Range("$A$1"))
.name = Mid(NomChargement, 1, Len(NomChargement) - 4)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1 'variable
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Else
If a = 2 Or a = 4 Then
Right(NomFichier, 3) = "ril"
ElseIf a = 3 Then
Right(NomFichier, 3) = "tir"
Else
GoTo Erreur_type_fichier
End If
'****************************************************************************************************************************************
'Activation du classeur qui va recevoir les données
Classeur2.Activate
Classeur2.Worksheets(Left(extension, 6)).Activate
' ----- import data
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & NomFichier, Destination:=Range("$A$1"))
.name = Mid(NomChargement, 1, Len(NomChargement) - 4)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1 'variable
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
'enregistrement des étapes dans la feuille "register-1" du classeur Source
ClasseurPrincipale.Activate
ClasseurPrincipale.Ws6.Cells((a / 2) + 20, 1).Value = NomFichier
ClasseurPrincipale.Ws6.Cells((a / 2) + 20, 2).Value = a
ClasseurPrincipale.Ws6.Cells((a / 2) + 20, 3).Value = Nomtypefichier
ClasseurPrincipale.Ws6.Cells((a / 2) + 20, 4).Value = sheet
'revenir sur le classeur créé
Classeur2.Activate
End If
'Determine how many seconds code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
Application.StatusBar = "The macro run for : " & MinutesElapsed & " minutes."
'****************************************************************************************************************************************
Next a
'détermination de la dernière ligne
For d = 1 To (NombredeFichier * 2)
On Error Resume Next
derligne = Classeur2.Worksheets(d).Cells(Rows.Count, 1).End(xlUp).Row
If derligne = 1 Then
GoTo 1
End If
'enlever tous les points et les remplacer par des virgules
Classeur2.Worksheets(d).Activate
Classeur2.Worksheets(d).name = Left(extension, 6)
Range("A1:A" & derligne).Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
'Séparer les données dans les colonnes
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=True, Comma:=False, Space:=True, Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
TrailingMinusNumbers:=True
'Mise en page
Columns("A:D").EntireColumn.AutoFit
1: Next d
'****************************************************************************************************************************************
'Traitement de l'information
For e = 1 To (NombredeFichier * 2)
Classeur2.Worksheets(e).Activate
derligne = Classeur2.Worksheets(e).Cells(Rows.Count, 1).End(xlUp).Row
If derligne = 1 Then
GoTo 2
End If
'suppression des valeurs non numérique et des lignes vides
For f = derligne To 1 Step -1
If Val(Left(Classeur2.Worksheets(e).Cells(f, 1).Value, 1)) = 0 And Left(Classeur2.Worksheets(e).Cells(f, 1).Value, 1) <> "-" Then
Rows(f).Select
Selection.Delete
End If
Next f
'copier-coller des valeurs en quinquonces
For b = 2 To derligne Step 2
derligne = Classeur2.Worksheets(e).Cells(Rows.Count, 1).End(xlUp).Row
If derligne = 1 Then
GoTo 2
End If
Classeur2.Worksheets(e).Range("A" & b & ":" & "D" & b).Select
Selection.Cut Destination:=Classeur2.Worksheets(e).Cells(b - 1, 5)
Next b
'suppression des lignes vides
For c = (derligne - 1) To 1 Step -2
derligne = Classeur2.Worksheets(e).Cells(Rows.Count, 1).End(xlUp).Row
If derligne = 1 Then
GoTo 2
End If
If Classeur2.Worksheets(e).Cells(c, 1).Value = Empty Then
Rows(c).Select
Selection.Delete
End If
Next c
2: Next e
'sauvegarder le classeur créé
Classeur2.Save
End If
'****************************************************************************************************************************************
'copie entre fichier
For h = 1 To (NombredeFichier * 2)
Classeur2.Worksheets(h).Activate
derligne = Classeur2.Worksheets(h).Cells(Rows.Count, 1).End(xlUp).Row
x = derligne > 60000 And derligne < 120000
If derligne = 1 Then
GoTo 3
ElseIf x And Classeur2.Worksheets(h).name = "80_tir" Then
'diviser les valeurs en deux feuilles - Meme classeur
Classeur2.Worksheets(h).Activate
Range("A60001:H" & derligne).Select
Selection.Cut Destination:=Classeur2.Worksheets(h + 1).Cells(1, 1)
'collage (1/2)---------
Classeur2.Worksheets(h).Activate '"80_tir"
Cells.Select
Selection.Copy
ClasseurPrincipale.Ws7.Activate 'feuille 1
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'collage (2/2)---------
Classeur2.Worksheets(h + 1).Activate '"80_tir (2)"
derligne = Classeur2.Worksheets(h + 1).Cells(Rows.Count, 1).End(xlUp).Row
Cells.Select
Selection.Copy
ClasseurPrincipale.Ws8.Activate 'feuille 2
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ElseIf x And Classeur2.Worksheets(h).name = "80_ril" Then
'diviser les valeurs en deux feuilles - Meme classeur
Classeur2.Worksheets(h).Activate '"80_ril"
Range("A60001:H" & derligne).Select
Selection.Cut Destination:=Classeur2.Worksheets(h + 1).Cells(1, 1) '"80_ril (2)"
'collage (1/2)---------
Classeur2.Worksheets(h).Activate '"80_ril"
Cells.Select
Selection.Copy
ClasseurPrincipale.Ws7.Activate 'feuille 1
Range("J1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'collage (2/2)---------
Classeur2.Worksheets(h + 1).Activate '"80_ril (2)"
derligne = Classeur2.Worksheets(h + 1).Cells(Rows.Count, 1).End(xlUp).Row
Cells.Select
Selection.Copy
ClasseurPrincipale.Ws8.Activate 'feuille 2
Range("J1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ElseIf x And Classeur2.Worksheets(h).name = "50_tir" Then
'collage
Classeur2.Worksheets(h).Activate '"50_tir"
Cells.Select
Selection.Copy
ClasseurPrincipale.Activate
If FeuilleExiste("3") Then
ClasseurPrincipale.Sheets.Add
Set Ws9 = Sheets("3")
End If
ClasseurPrincipale.Ws9.Activate 'feuille 3
derligne = Classeur2.Ws9.Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & derligne + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ElseIf x And Classeur2.Worksheets(h).name = "50_ril" Then
'collage
Classeur2.Worksheets(h).Activate '"50_ril"
Cells.Select
Selection.Copy
ClasseurPrincipale.Activate
If FeuilleExiste("3") Then
ClasseurPrincipale.Sheets.Add
Set Ws9 = Sheets("3")
End If
ClasseurPrincipale.Ws9.Activate 'feuille 3
derligne = Classeur2.Ws9.Cells(Rows.Count, 1).End(xlUp).Row
Range("J" & derligne + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
3: Next h
'suppression des feuilles vides dans le Classeur2
Classeur2.Activate
For Each shFeuille In Classeur2.Worksheets
If Classeur2.Worksheets(shFeuille).Cells.Find("*") Is Nothing Then
Application.DisplayAlerts = False
Selection.Delete
Application.DisplayAlerts = False
End If
Next shFeuille
'__________________________________________2)_PUT ALL DATA IN FEW SHEETS________________________________
'si action annulée lors du chargment du fichier NomFichier
Stage2:
'déclaration des variables
Dim lastpastline As Long, begincopyline As Long, lastcopyline As Long 'variable pour état des lieux des données existantes
Dim i As Integer 'variable pour boucle sur nombre de feuille
Dim l As Long
Dim newresultsheet As Boolean, newdatasheet As Boolean 'variable de condition pour le nombre de feuille
Dim namedatasheet As String 'variable pour nom des feuilles
Dim nameresultsheet As String
'initialisation des variables
a = 0
g = 3
newresultsheet = True
lastpastline = 1
begincopyline = 1
lastcopyline = 0
For i = 1 To 8
namedatasheet = Right(Str(i), 1) ' create in string tghe namedatasheet of the datasheet
' ----- check if new datasheet has been started
If newdatasheet = True Then
begincopyline = 1 ' start from beginning
Else
begincopyline = lastcopyline + 1 ' start copying where it has stopped
End If
' ----- check if new result sheet need to be created to register data
If newresultsheet = True Then
a = a + 1
nameresultsheet = "result-" & a ' name new result sheet "result-a"
clearcreatesheet name:=nameresultsheet, clear:=1 ' check that a sheet called "result-a" exist or creat it
lastpastline = 0 ' start pasting from first line (page is new)
Else
checksheetstop name:=namedatasheet ' check that a datasheet called "i" exist and stop if not
End If
' ----- check how many lines left to copy from the data sheet "i"
For l = begincopyline To 65000 ' loop for the begincopyline line (where copy should start) to the end of the sheet
If Sheets(namedatasheet).Cells(l, 1) = "" Then ' If a empty line is met
If Sheets(namedatasheet).Cells(l, 2) = "" Then
If Sheets(namedatasheet).Cells(l, 3) = "" Then
If Sheets(namedatasheet).Cells(l, 4) = "" Then
If Sheets(namedatasheet).Cells(l, 5) = "" Then
If Sheets(namedatasheet).Cells(l, 6) = "" Then
If Sheets(namedatasheet).Cells(l, 7) = "" Then
If Sheets(namedatasheet).Cells(l, 8) = "" Then
If Sheets(namedatasheet).Cells(l, 10) = "" Then
If Sheets(namedatasheet).Cells(l, 11) = "" Then
If Sheets(namedatasheet).Cells(l, 12) = "" Then
If Sheets(namedatasheet).Cells(l, 13) = "" Then
If Sheets(namedatasheet).Cells(l, 14) = "" Then
If Sheets(namedatasheet).Cells(l, 15) = "" Then
If Sheets(namedatasheet).Cells(l, 16) = "" Then
If Sheets(namedatasheet).Cells(l, 17) = "" Then
lastcopyline = l - 1 ' Register lastcopyline = number of line with data on teh datasheet
Exit For
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next l
' ----- check if enough space or not
If lastcopyline - begincopyline + lastpastline > 65000 Then ' If there is not enough place to copy all the data
lastcopyline = 65000 - lastpastline + begincopyline ' Then register a maximum line that will be used to know until when copy
i = i - 1 ' Register for next step to stay on the same data sheet (as copy won't be finished)
newresultsheet = True ' Keep for next loop the information that It will be needed to create a new resultsheet
newdatasheet = False ' Keep for next loop the information that it won't be needed to switch to a new datasheet
ElseIf lastcopyline - begincopyline + lastpastline = 65000 Then ' If there is exactly the place to copy all the data
newresultsheet = True ' Keep for next loop the information that It will be needed to create a new resultsheet
newdatasheet = True ' Keep for next loop the information that it won't be needed to switch to a new datasheet
Else ' If there is enough place
newresultsheet = False ' Keep for next loop the information that it won't be needed to create new resultsheet
newdatasheet = True ' Keep for next loop the information that it won't be needed to switch to a new datasheet
End If
' ----- Copy data ------------------
' ----- Direct/ Tir Max/Min Torque
Worksheets(namedatasheet).Select ' select datasheet
Range(Cells(begincopyline, 1), Cells(lastcopyline, 1)).Copy ' copy from begincopyline to lastcopyline
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 2) ' past after lastpastline
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 5), Cells(lastcopyline, 5)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 3)
' ----- Direct / Tir Max/Min Angle
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 2), Cells(lastcopyline, 2)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 5)
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 6), Cells(lastcopyline, 6)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 6)
' ----- Retro / Ril Max/Min Torque
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 10), Cells(lastcopyline, 10)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 8)
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 14), Cells(lastcopyline, 14)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 9)
' ----- Retro / Tir Max/Min Angle
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 11), Cells(lastcopyline, 11)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 11)
Worksheets(namedatasheet).Select
Range(Cells(begincopyline, 15), Cells(lastcopyline, 15)).Copy
ActiveSheet.Paste Destination:=Worksheets(nameresultsheet).Cells(lastpastline + 1, 12)
Worksheets("register1").Cells(g, 3).Value = "Copy " & namedatasheet & " lines " & begincopyline & "-" & lastcopyline & ". Paste " & nameresultsheet & " lines " & lastpastline & "-" & lastpastline + lastcopyline - begincopyline
g = g + 1
' ----- update the last line used to past the data
lastpastline = lastpastline + lastcopyline - begincopyline
' ----- if last line used to past the data is 65000 then put it to 0
If lastpastline = 65000 Then
lastpastline = 0
End If
Next i
'*************************************************************************************************************************************
Application.DisplayStatusBar = False
Application.ScreenUpdating = True
End Sub
'sheet called "Register1" needed to use the form, create or clear
Public Sub clearcreatesheet(name As String, clear As Integer)
Dim compteur_feuille
Dim presence As Integer
presence = 0
ClasseurPrincipale.Activate
' ----- find the number of the first sheet called "name"
For compteur_feuille = 1 To Worksheets.Count ' loop for all sheets of the file
If Worksheets(compteur_feuille).name = name Then ' if the first sheet's name is "name"
presence = compteur_feuille ' then register the number of this sheet
End If
Next compteur_feuille
' ----- if no sheet is called "name", create one and place at the end
If presence = 0 Then
Sheets.Add.name = name 'create the sheet if does not exist
ActiveSheet.Move After:=Sheets(Worksheets.Count + 4) 'place it(at the end)
Else
If clear = 1 Then ' if this is the first time this sheet is used
Worksheets(presence).Select
Range("A:T").ClearContents 'clear the sheet if exist
Worksheets(presence).Move After:=Sheets(Worksheets.Count + 4) 'place it (at the end)
ElseIf clear = 2 Then
Worksheets(presence).Move After:=Sheets(Worksheets.Count + 4) 'place it (at the end) if this is second time do not clean the sheet
End If
End If
End Sub
Public Sub checksheetstop(name As String)
Dim compteur_feuille
Dim presence As Integer
presence = 0
ClasseurPrincipale.Activate
' ----- find the number of the first sheet called "name"
For compteur_feuille = 1 To Worksheets.Count ' loop for all sheets of the file
If Worksheets(compteur_feuille).name = name Then ' if the first sheet's name is "name"
presence = compteur_feuille ' then register the number of this sheet
End If
Next compteur_feuille
' ----- if no sheet is called "name", create one and place at the end
If presence = 0 Then
End
End If
End Sub |
Ecrire et modifier un fichier .txt en VBA
Répondre avec citation
Envoyé par U_goffu
Partager