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.
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.
Na het uitvoeren van de macro had ik de volgende mappen (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.
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
Hoi Theo Schipper
Ik zou in mijn submap een bestand willen zetten. Is dat mogelijk? En weet u hoe dat ik dat dan zou moeten doen?
Alvast bedankt.
Gr Theo
Hoi Eb,
Maak je gebruik van vreemde tekens in de mapnamen? Het kan zijn dat een map niet gemaakt kan worden omdat Windows de bestandsmap naam niet accepteert namelijk.
Gr Theo
Theo, ik heb het opgelost zat denk ik de naam of structuur van een van de mappen weet het niet precies maar die is nu handmatig aangemaakt. Thx i.i.g.
Theo, is heb hetzelfde als Eb, Ik had het werkend maar ineens krijg ik die melding waar kan dat aanliggen denk je. Ik heb ook al een andere computer geprobeerd maar hetzelfde ik krijg de foutmelding.
Eb, en Theo is heb precies het zelfde van alles geprobeerd andere computer geprobeerd. Eerst lukt het wel toen eens kwam deze melding.
Hoi Theo, als ik de macro start en een map kies krijg ik de MS VBA fout melding dat hij het pad niet kan vinden, Verschillende mappen etc geprobeerd maar krijg het niet werkende, doe ik wat verkeerd?
Hoi URS,
Zekers, in het voorbeeld heb de naam Sub map gebruikt, maar in kolom B en C en verder kun je invullen welke mapnaam je ook maar wilt hebben.
Gr Theo
kun je dit ook doen als alle mappen verschillende namen hebben?