Onlangs moest ik een map maken in windows voor een digitaal dossier. De windows mappen structuur was telkens hetzelfde. 1 hoofdmap met een aantal sub-mappen. De sub-mappen hadden telkens dezelfde naam, alleen de hoofdmap had een afwijkende naam.

Voorbeeld windows mappen
Voorbeeld mappen

Om alles handmatig te doen was onbegonnen werk met zo’n 20.000 records. De informatie kon ik in excel omzetten dus uiteindelijk startte ik de zoektocht naar een macro die daar mappen van zou kunnen maken. En die vond ik!


Data in excel bestand klaar zetten

In het excel bestand moet eerst de data juist gezetten worden. In afbeelding 1 staat hoe ik mijn structuur moest hebben.

Afbeelding 1
Afbeelding 1

Na het uitvoeren van de macro had ik de volgende mappen (afbeelding 2):

Afbeelding 2
Afbeelding 2

Zoals je ziet heb ik hier zelfs nog een sub sub map gemaakt. Hierin kun je doorgaan zolang je wilt. Met deze methode heb ik uiteindelijk een klanten dossier gemaakt en een digitale agenda voor opslaan van gegevens belangrijk voor die datum. Je kunt het bestand uiteraard ook gebruiken voor bijvoorbeeld muziek catalogus, foto’s en documenten.

Zodra je de macro start zal eerst worden gevraagd waar je de mappen wilt opslaan.

Download bron bestand
  mappen-maken-met-excel.xlsm – Bestandsgrootte 16,3 Kb  

De macro’s voor windows mappen

De gehele macro bestaat uit 3 delen.

Gedeelte 1

Sub MappenMakenMetExcel()

 baseFolder = BrowseForFolder
 If (baseFolder = False) Then
 Exit Sub
 End If
 Set fs = CreateObject("Scripting.FileSystemObject")
 For iRow = 1 To 6500
 pathToCreate = baseFolder
 leafFound = False
 For iColumn = 1 To 6500
 currValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value
 If (currValue = "" And leafFound) Then
 Exit For
 ElseIf (currValue = "") Then
 parentFolder = FindParentFolder(iRow, iColumn)
 If (parentFolder = False) Then
 Exit For
 Else
 pathToCreate = pathToCreate & "\" & parentFolder
 If Not (fs.FolderExists(pathToCreate)) Then
 fs.CreateFolder (pathToCreate)
 End If
 End If
 Else
 leafFound = True
 pathToCreate = pathToCreate & "\" & currValue
 If Not (fs.FolderExists(pathToCreate)) Then
 fs.CreateFolder (pathToCreate)
 End If
 End If
 Next
 If (leafFound = False) Then
 Exit For
 End If
 Next
End Sub

Gedeelte 2

Function FindParentFolder(row, column)
 For iRow = row To 0 Step -1
 currValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column).Value
 If (currValue <> "") Then
 FindParentFolder = CStr(currValue)
 Exit Function
 ElseIf (column <> 1) Then
 leftValue = Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, column - 1).Value
 If (leftValue <> "") Then
 FindParentFolder = False
 Exit Function
 End If
 End If
 Next
End Function

Gedeelte 3

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
 'Function purpose: To Browser for a user selected folder.
 'If the "OpenAt" path is provided, open the browser at that directory
 'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
 Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 'Set the folder to that selected. (On error in case cancelled)
 On Error Resume Next
 BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0

'Destroy the Shell Application
 Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
 'handler if found
 'Valid selections can begin L: (where L is a letter) or
 '\\ (as in \\servername\sharename. All others are invalid
 Select Case Mid(BrowseForFolder, 2, 1)
 Case Is = ":"
 If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
 Case Is = "\"
 If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
 Case Else
 GoTo Invalid
 End Select

Exit Function

Invalid:
 'If it was determined that the selection was invalid, set to False
 BrowseForFolder = False

End Function