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
| Option Explicit
Dim fso, oFold, arrFolders, I, BeginPath, FD, tmp
' Tableau ordonné suivant le niveau de chaque sous-dossier :
' arrFolders = Array("PRJ-2018-00000748", "XJF-XJI Sq 52", "Lot 1", "Lot 2", "Lot 3", "RJI", "CF", "CO", "VPC")
'Indices des éléments : 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8
'Niveau 1 2 3 3 3 3 4 4 4
' Le tableau est rempli par la Sub FillTable à partir du fichier excel.
FillTable
BeginPath = "C:\Temp\" ' Mettre ici le chemin correct
Set fso = CreateObject("Scripting.FileSystemObject")
tmp = BeginPath & arrFolders(0)
If Not fso.FolderExists(tmp) Then
Set oFold = fso.CreateFolder(tmp)
Else
' (1) : Sans cette instruction, si le dossier existe, il y a erreur car il n'y aurait pas d'objet oFold
Set oFold = fso.GetFolder(tmp)
End If
' oFold.Path correspond maintenant à C:\Temp\PRJ-2018-00000748\XJF-XJI Sq 52
tmp = AddDirSep(oFold.Path) & arrFolders(1)
If Not fso.FolderExists(tmp) Then
Set oFold = fso.CreateFolder(tmp)
Else
' (2) : Même remarque que (1)
Set oFold = fso.GetFolder(tmp)
End If
' Création des sous-dossiers Lot 1, Lot 2, Lot 3 et RJI dans le sous-dossier XJF-XJI Sq 52
For I = 2 to 5
tmp = AddDirSep(oFold.Path) & arrFolders(I)
If Not fso.FolderExists(tmp) Then fso.CreateFolder(tmp)
Next
'Création des sous-dossiers CF, CO et VPC dans chacun des 4 sous-dossiers précédents
For Each FD IN oFold.SubFolders
For I = 6 To 8
tmp = AddDirSep(FD.Path) & arrFolders(I)
If Not fso.FolderExists(tmp) Then fso.CreateFolder(tmp)
Next 'I
Next ' FD
'=======================================
Function AddDirSep(strFolder)
' On s'assure que le chemin se termine par le caractère \
If Right(strFolder, 1 ) <> "\" Then strFolder = strFolder & "\"
AddDirSep = strFolder
End Function
'=======================================
Sub FillTable()
Const xlGuess = 0, ForWriting = 2
Dim Cnt, XL, WB, Sht, I
Set XL = CreateObject("Excel.Application")
XL.Visible = True
XL.DisplayAlerts = False
Set WB = XL.Workbooks.Open("C:\Temp\SourceFile.xls") ' Mettre le chemin correct du fichier
Set Sht = WB.Worksheets("Feuil1")
'Syntaxe pour le tri :
'Expression.Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3)
Sht.Range("A1").Sort Sht.Columns("A"), , , , , , , xlGuess ' header=0(valeur:xlGuess) : ne prend pas en compte la ligne d'en-tête.
Cnt = Sht.UsedRange.Rows.Count
ReDim arrFolders(0)
For I = 2 To Cnt
With Sht
ReDim Preserve arrFolders(I-2)
arrFolders(I-2) = .Cells(I, 2)
End With
Next
'Enregistrement ou non ? Même si on n'enregistre pas,
'les données sont triées et passées au tableau arrFolders dans l'ordre voulu
If MsgBox("Enregistrer les modification ?",vbYesNo+vbExclamation,"Enregistrer " & WB.Name) = vbYes Then WB.Save
'Fermetuure d'excel et nettoyage
XL.Quit
Set XL = Nothing
End Sub |
