Folder Tree using VBA

[Prince27]

Hi,

I need to create a Folder Tree based on below snip:

1. Main Folder is from "Column A".
2. Sub 1, Sub 2, etc., are the sub folders.
3. Under each Sub 1, Sub 2., there are super sub folders.

All the sub folders and super sub folders are common in nature. Here, i require your expertise with the help of VBA, to create Main Folder based on Column A, sub folders and super sub folders based on the below.

My output should look like the below:

Thank you in advance for your help.

 

[Prince27]

Hello experts,

Did any get a chance to look into the above ask . Appreciate your help

 

[Fluff]

Please do not mark a post that doesn't contain a solution as the solution, especially when you are still looking for help.

 

[Logit]

Directing the following code to the upper most folder, you'll generate the folder list (I believe) that you want :

Option Explicit

Public Position As Integer
Public Indent As Integer

Sub ListFileTree()

Position = 0
Indent = 0

Call RecurseFolderList(Range("A1").Value)

End Sub

Private Sub ClearFormatting(Rng As Range)

    Rng.Formula = Rng.Value2
    Rng.Font.ColorIndex = xlAutomatic
    Rng.Font.Underline = xlUnderlineStyleNone

End Sub

Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

Function RecurseFolderList(FolderName As String) As Boolean
    On Error Resume Next
    Dim FSO, NextFolder, FolderArray, FileArray, NextFile
    Dim OriginalRange As Range
    Dim RemoveHyperlink As Boolean
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Err.Number > 0 Then
        RecurseFolderList = False
    Exit Function

    End If

    On Error GoTo 0
    If FSO.FolderExists(FolderName) Then

        Set NextFolder = FSO.GetFolder(FolderName)
        Set FolderArray = NextFolder.SubFolders
        Set FileArray = NextFolder.Files

        RemoveHyperlink = False
        Set OriginalRange = Range("A2").Offset(Position - 1, Indent)

        Indent = Indent + 1

        For Each NextFolder In FolderArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & UCase(GetFilenameFromPath(NextFolder)) & """)"
            Position = Position + 1

            RecurseFolderList (NextFolder)

            RemoveHyperlink = True
        Next

        For Each NextFile In FileArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & GetFilenameFromPath(NextFile) & """)"
            Position = Position + 1

            RemoveHyperlink = False

            DoEvents
        Next

        If RemoveHyperlink Then
            Call ClearFormatting(OriginalRange)
        End If

        Set NextFolder = Nothing
        Set FolderArray = Nothing
        Set FileArray = Nothing
        Set NextFile = Nothing

    Else
        RecurseFolderList = False
    End If

    Set FSO = Nothing
    Indent = Indent - 1

End Function

Download workbook : Internxt Drive

 

[Prince27]

Directing the following code to the upper most folder, you'll generate the folder list (I believe) that you want :

Option Explicit

Public Position As Integer
Public Indent As Integer

Sub ListFileTree()

Position = 0
Indent = 0

Call RecurseFolderList(Range("A1").Value)

End Sub

Private Sub ClearFormatting(Rng As Range)

    Rng.Formula = Rng.Value2
    Rng.Font.ColorIndex = xlAutomatic
    Rng.Font.Underline = xlUnderlineStyleNone

End Sub

Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

Function RecurseFolderList(FolderName As String) As Boolean
    On Error Resume Next
    Dim FSO, NextFolder, FolderArray, FileArray, NextFile
    Dim OriginalRange As Range
    Dim RemoveHyperlink As Boolean
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Err.Number > 0 Then
        RecurseFolderList = False
    Exit Function

    End If

    On Error GoTo 0
    If FSO.FolderExists(FolderName) Then

        Set NextFolder = FSO.GetFolder(FolderName)
        Set FolderArray = NextFolder.SubFolders
        Set FileArray = NextFolder.Files

        RemoveHyperlink = False
        Set OriginalRange = Range("A2").Offset(Position - 1, Indent)

        Indent = Indent + 1

        For Each NextFolder In FolderArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & UCase(GetFilenameFromPath(NextFolder)) & """)"
            Position = Position + 1

            RecurseFolderList (NextFolder)

            RemoveHyperlink = True
        Next

        For Each NextFile In FileArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & GetFilenameFromPath(NextFile) & """)"
            Position = Position + 1

            RemoveHyperlink = False

            DoEvents
        Next

        If RemoveHyperlink Then
            Call ClearFormatting(OriginalRange)
        End If

        Set NextFolder = Nothing
        Set FolderArray = Nothing
        Set FileArray = Nothing
        Set NextFile = Nothing

    Else
        RecurseFolderList = False
    End If

    Set FSO = Nothing
    Indent = Indent - 1

End Function

Download workbook : Internxt Drive

Hi,

Firstly, thank you for your reply.

However, i'm unable to execute the code provided above, i dont see the result as intended nor any error message.

Attaching snippet of how my actual excel looks like on which the macro should run

Thank you in advance for your support

 

[Prince27]

Hi,

My output should look like this:

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: VBA to create Folder Tree - Sub and Super Sub Folders
There is no need to repeat the link(s) provided above but if you have posted the question at other places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[Fluff]

Please do not mark a post as the solution when it does not contain one. Thanks