Create a File list with metadata

[santh]

Hello everyone,

I have a folder structure with an extended number of subfolders and at the last level there are documents, many of them. I want to generate an excel Document list and at the moment i can only create the folder structure (please see attachment). The last column should have the actual documents as a hyperlink that when you click on them, they open. Can you please help??

[paulked]

Try:


Sub StoreSubFolder(baseFolderObj, ByRef iRow, ByVal iColumn)
Dim oFile As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set folderBase = fs.GetFolder(baseFolderObj)
Set folderBaseSubs = folderBase.SubFolders
iRow = iRow + 1
iColumn = iColumn + 1
For Each subfolder In folderBaseSubs
Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = subfolder.Name
StoreSubFolder subfolder, iRow, iColumn
For Each oFile In subfolder.Files
If InStr(oFile, ".xls") > 0 Then
iRow = iRow + 1
ActiveSheet.Hyperlinks.Add Cells(iRow, iColumn + 1), oFile.Path, , , oFile.Name
End If
Next
Next
End Sub

[santh]

It didn't work! What am i doing wrong?

[paulked]

Post your updated code.

[santh]

Sub ImportFolderStructure()
'Import folder structure starting from selected base folder
'each subfolder will be stored in a separete cell
'eg:
'Folder 1|Subfolder1|SubSubfolder1
'Folder 2|Subfolder2
'Folder 3|Subfolder3|SubSubfolder3


'...
Application.ScreenUpdating = False
baseFolder = BrowseForFolder
If (baseFolder = False) Then
Exit Sub
End If
Application.StatusBar = "Folder structure below " & baseFolder & " will be stored in the sheet " & ActiveCell.Worksheet.Name
StoreSubFolder baseFolder, 1, 0
Application.StatusBar = "Folder structure below " & baseFolder & " has been stored in the sheet " & ActiveCell.Worksheet.Name
Range("A2").Select
Application.ScreenUpdating = True
End Sub




Sub StoreSubFolder(baseFolderObj, ByRef iRow, ByVal iColumn)
Set fs = CreateObject("Scripting.FileSystemObject")
Set folderBase = fs.GetFolder(baseFolderObj)
Set folderBaseSubs = folderBase.SubFolders
iRow = iRow + 1
iColumn = iColumn + 1
For Each subfolder In folderBaseSubs
Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = subfolder.Name
StoreSubFolder subfolder, iRow, iColumn
Next
End Sub


Sub ClearImportData()
Application.ScreenUpdating = False
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Range("A2").Select
Application.ScreenUpdating = True
End Sub
Sub CreateFolderStructure()
'Create folder for all vlues in current sheet
'folders will be created in folder where the excel file was saved
'folders will be created from first row, first column, until empty row is found
'Example expected cell structure: (data starting in current sheet, column A, row 1)
'folder1 subfolder1 subsubfolder1
'folder2
'folder3 subfolder3
' subfolder4
'...
'this will result in:
'<currentpath>\folder1\subfolder1\subsubfolder1
'<currentpath>\folder2
'<currentpath>\folder3\subfolder3
'<currentpath>\folder3\subfolder4
'...
baseFolder = BrowseForFolder
If (baseFolder = False) Then
Exit Sub
End If
Set fs = CreateObject("Scripting.FileSystemObject")
For iRow = 2 To 6500
pathToCreate = baseFolder
leafFound = False
For iColumn = 1 To 6500
currValue = Trim(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replac e(Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value, ":", "-"), "*", "-"), "?", "-"), Chr(34), "-"), "<", "-"), ">", "-"), "|", "-"), "/", "-"), "", "-"))
Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = currValue
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
CreateDirs (pathToCreate)
End If
End If
Else
leafFound = True
pathToCreate = pathToCreate & "" & currValue
If Not (fs.FolderExists(pathToCreate)) Then
CreateDirs (pathToCreate)
End If
End If
Next
If (leafFound = False) Then
Exit For
End If
Next
End Sub


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




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


Sub CreateDirs(MyDirName)
' This subroutine creates multiple folders like CMD.EXE's internal MD command.
' By default VBScript can only create one level of folders at a time (blows
' up otherwise!).
'
' Argument:
' MyDirName [string] folder(s) to be created, single or
' multi level, absolute or relative,
' "d:\folder\subfolder" format or UNC

Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild


' Create a file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")


' Convert relative to absolute path
strDir = objFSO.GetAbsolutePathName(MyDirName)


' Split a multi level path in its "components"
arrDirs = Split(strDir, "")


' Check if the absolute path is UNC or not
If Left(strDir, 2) = "" Then
strDirBuild = "" & arrDirs(2) & "" & arrDirs(3) & ""
idxFirst = 4
Else
strDirBuild = arrDirs(0) & ""
idxFirst = 1
End If


' Check each (sub)folder and create it if it doesn't exist
For i = idxFirst To UBound(arrDirs)
strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i))
If Not objFSO.FolderExists(strDirBuild) Then
objFSO.CreateFolder strDirBuild
End If
Next


' Release the file system object
Set objFSO = Nothing
End Sub



Sub StoreSubFolder(baseFolderObj, ByRef iRow, ByVal iColumn)
Dim oFile As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set folderBase = fs.GetFolder(baseFolderObj)
Set folderBaseSubs = folderBase.SubFolders
iRow = iRow + 1
iColumn = iColumn + 1
For Each subfolder In folderBaseSubs
Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = subfolder.Name
StoreSubFolder subfolder, iRow, iColumn
For Each oFile In subfolder.Files
If InStr(oFile, ".xls") > 0 Then
iRow = iRow + 1
ActiveSheet.Hyperlinks.Add Cells(iRow, iColumn + 1), oFile.Path, , , oFile.Name
End If
Next
Next
End Sub

[paulked]

You can't have two Sub's called StoreSubFolder! Delete the first one.

I also switched two lines in the code (in red) so replace the second one with:


Sub StoreSubFolder(baseFolderObj, ByRef iRow, ByVal iColumn)
Dim oFile As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set folderBase = fs.GetFolder(baseFolderObj)
Set folderBaseSubs = folderBase.SubFolders
iRow = iRow + 1
iColumn = iColumn + 1
For Each subfolder In folderBaseSubs
Worksheets(ActiveCell.Worksheet.Name).Cells(iRow, iColumn).Value = subfolder.Name
StoreSubFolder subfolder, iRow, iColumn
For Each oFile In subfolder.Files
If InStr(oFile, ".xls") > 0 Then
ActiveSheet.Hyperlinks.Add Cells(iRow, iColumn + 1), oFile.Path, , , oFile.Name
iRow = iRow + 1
End If
Next
Next
End Sub


Also, when posting code, please use the code tags (# button on the edit window). It makes it far easier to read :thumb

[santh]

I am sorry for being basic, i haven't used VBA for ever and i have forgotten everything! Thank you so much for your time and patience

It kind of works now that i deleted the duplicate, but i need all kind of file extensions to be able to be added and hyperlinked

[paulked]

I want to generate an excel Document list

That's why it only picks up Excel documents. Delete the If statement so:



For Each oFile In subfolder.Files
If InStr(oFile, ".xls") > 0 Then
ActiveSheet.Hyperlinks.Add Cells(iRow, iColumn + 1), oFile.Path, , , oFile.Name
iRow = iRow + 1
End If
Next

Changes to:


For Each oFile In subfolder.Files
ActiveSheet.Hyperlinks.Add Cells(iRow, iColumn + 1), oFile.Path, , , oFile.Name
iRow = iRow + 1
Next

[santh]

Thank you so much! You are the best!!! Yes it works perfectly!

[paulked]

You're welcome :thumb