Creation de base de données

Dim Chemin As String

Sub creer_rep_et_sous_rep()
' déclaration des variables amenées à stocker les noms des dossiers et sous dossiers
Dim nomrepertoire, nomsousrepertoire As String
' déclaration des variables i & j pour boucler sur les cellules
' & derlig et dercol pour connaitre la dernière ligne et dernière colonne du tableau
Dim i, j, derlig, dercol As Integer
'on appelle la fonction parcourir pour choisir le répertoire ou seront créés nos dossiers
Call parcourir
'dernière ligne du tableau
derlig = Range("A65536").End(xlUp).Row
'derniere colonne du tableau
dercol = Range("A1").SpecialCells(xlCellTypeLastCell).Column
'de la ligne 2 à la dernière ligne
For i = 2 To derlig
'première colonne (pour la création du répertoire "projet")
'nom du répertoire = contenu cellule(i, colonne A)
nomrepertoire = Cells(i, 1)
's'il n'y a rien dans la cellule, on ne fait rien
If nomrepertoire <> "" Then
'test si le répertoire existe
If RépertoireExiste(Chemin & "\" & nomrepertoire) = False Then
's'il n'existe pas, on créé le lien hypertexte
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, j), Address:=Chemin & "\" & nomrepertoire
'on créé le répertoire
MkDir Chemin & "\" & nomrepertoire
End If
End If
'boucle sur les colonnes de 2 à la dernière pour créer les sous dossiers
For j = 2 To dercol
nomsousrepertoire = Cells(i, j)
If nomsousrepertoire <> "" Then
If RépertoireExiste(Chemin & "\" & nomrepertoire & "\" & nomsousrepertoire) = False Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, j), Address:=Chemin & "\" & nomrepertoire & "\" & nomsousrepertoire
MkDir Chemin & "\" & nomrepertoire & "\" & nomsousrepertoire
End If
End If
Next j
Next i
End Sub
'http://www.commentcamarche.net/faq/sujet-16109-excel-convertir-fichier-s-csv-xls
Sub parcourir()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
    On Error Resume Next
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    Set objShell = Nothing
    Set objFolder = Nothing
    Set oFolderItem = Nothing
End Sub
'http://frederic.sigonneau.free.fr/code/Fichiers/RepertoireExiste.txt
Function RépertoireExiste(emplacement As String) As Boolean
  On Error Resume Next
  RépertoireExiste = GetAttr(emplacement) And vbDirectory
End Function