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 |
Partager