Directory mapping macro - need more robust code

[bantam]

Hi all,

This is the first excel macro that I have ever tried to set up, it is essentially just pieces of code that were pulled from the web and slightly modified.

The objective is to put a workbook with this macro into a main folder, execute the macro, and have the macro navigate through and display the subfolders and files as hyperlinks.

The first set of sub-folders are created as new sheets, and all of the remaining "sub-sub" folders and files are added to that sheet.

This macro actually works very well at times, but at other times, seems to break quite easily. The first thing that I noticed was that the code seems to break when the sheet names have spaces in them.

I was able to somewhat improve the functionality by removing "& ActiveSheet.Name" from the following line:

RefersToR1C1:="=" & ActiveSheet.Name & "!R" & .Row & "C" & .Column

When I run the macro on a directory with spaces in the folder names, I get the following error window:

Run time Error 1004
Method 'Range' of Object '_global' failed.

One potential fix that I thought of would be to go through and replace all of the spaces in the folder names with underscores, but I would prefer not to do so.

I appreciate any advice that you can offer

Public Sub FolderMap()    Dim fso, oFolder, oSubfolder, oFile, queue As Collection
    Dim iFolder As Object
    Dim Directory As String
    Dim Problem As Boolean
    Dim ShellApp As Object
    Dim a As Integer
    Dim b As Integer
    Dim C As Integer
    Dim Ref As String
    Dim Fd As FileDialog
    Dim FileSys, Folder, SubFolders, Files
    
    Application.ScreenUpdating = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    
    
    Directory = ThisWorkbook.Path
    ' CATALOG DIRECTORY
    Set Folder = fso.GetFolder(Directory)
    Set iFolder = Folder.SubFolders
    
    For Each i In iFolder
        ' CHECK IF SHEET HAS ALREADY BEEN CREATED. EXCEL WILL NOT ALLOW
        ' YOU TO CREATE A SHEET WITH THE SAME NAME THIS ALLOWS THE
        ' PROGRAM TO REUSE THE SHEET BY DELETING THE THE INFORMATION
        ' CURRENTLY STORED WITHIN THE SHEET AND REPLACING WITH NEW
        ' FILES AND FOLDERS.
        '
        ' THIS WILL CREATE SHEETS FOR EACH MAIN FOLDER DIRECTLY UNDER
        ' THE JOB FOLDER. DO NOT STORE FILES IN THE MAIN JOB FOLDER
        ' DIRECTORY.
        Dim strSheetName As String
        strSheetName = i.Name
        If CreateSheetIf(strSheetName) Then
            'Do Nothing
        End If
        
        ' SETUP SHEET HEADER
        With ActiveSheet
            With .Range("A1")
                .Value = "Listing of all files in:"
                .ColumnWidth = 15
                If Val(Application.Version) > 8 Then
                    .Parent.Hyperlinks.Add _
                     Anchor:=.Offset(0, 1), _
                     Address:=Directory, _
                     TextToDisplay:=Directory
                Else
                    .Parent.Hyperlinks.Add _
                     Anchor:=.Offset(0, 1), _
                     Address:=Directory
                End If
            End With
        End With
        
        jobDirectory = Directory & "\" & strSheetName
        Set jobFolder = fso.GetFolder(jobDirectory)
        Set jobSubFolder = jobFolder.SubFolders
        queue.Add fso.GetFolder(jobDirectory)
        Do While queue.Count > 0
            Set oFolder = queue(1)
            queue.Remove 1 'dequeue


    Ref = jobDirectory
    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set Folder = FileSys.GetFolder(Ref)
    For Each j In ActiveWorkbook.Names
        j.Delete
    Next j
    With Cells
        .ClearContents
        .Font.Color = vbBlack
        .Font.Underline = False
        .Font.Bold = False
    End With
    Cells(1, 1).Select
    Application.ScreenUpdating = False
    With ActiveCell
        ActiveWorkbook.Names.Add Name:="A" & .Row & "_" & "B" & .Column, _
            RefersToR1C1:="=" & ActiveSheet.Name & "!R" & .Row & "C" & .Column


        ActiveSheet.Hyperlinks.Add Anchor:=Range(.Address), _
            Address:=Ref, TextToDisplay:=Folder.Name


        .Font.Bold = True
    End With
    a = 1
    b = 0
    Do Until ActiveWorkbook.Names.Count = 0
        Range(Names(1).Name).Select
        Ref = ActiveCell.Hyperlinks.Item(1).Address
        ActiveWorkbook.Names(1).Delete
        ActiveCell.Offset(1, 1).Select
        
        Set Folder = FileSys.GetFolder(Ref)
        Set SubFolder = Folder.SubFolders
        
        For Each j In SubFolder
            ActiveCell.Rows.EntireRow.Insert
            ActiveWorkbook.Names.Add Name:="A" & ActiveCell.Row & "_" & "B" & ActiveCell.Column, _
                RefersToR1C1:="=" & ActiveSheet.Name & "!R" & ActiveCell.Row & "C" & ActiveCell.Column
            ActiveSheet.Hyperlinks.Add Anchor:=Range(ActiveCell.Address), _
                Address:=Ref & "\" & j.Name, TextToDisplay:="'" & j.Name
            ActiveCell.Font.Bold = True
            ActiveCell.Offset(1, 0).Select
            a = a + 1
        Next
        
        Set Files = Folder.Files
        
        For Each j In Files
            ActiveCell.EntireRow.Insert
            ActiveSheet.Hyperlinks.Add Anchor:=Range(ActiveCell.Address), _
                Address:=Ref & "\" & j.Name, TextToDisplay:="'" & j.Name
            ActiveCell.Font.Bold = False
            ActiveCell.Offset(1, 0).Select
            b = b + 1
        Next
        C = a - ActiveWorkbook.Names.Count
        Application.StatusBar = "Folders: " & a & " found, " & C & " mapped; Files: " & b & " found, " & b & " mapped"
    Loop
    Cells.Columns.ColumnWidth = 7
       Loop
    Next
End Sub
Function CreateSheetIf(strSheetName As String) As Boolean
    Dim wsTest As Worksheet
    CreateSheetIf = False
     
    Set wsTest = Nothing
    On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
    On Error GoTo 0
     
    If wsTest Is Nothing Then
        CreateSheetIf = True
        Worksheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = strSheetName
    End If
    
    ActiveWorkbook.Worksheets(strSheetName).Activate
    
    ' CLEAR ENTIRE WORKSHEET FOR NEW CONTENT
    For Each i In ActiveWorkbook.Names
        i.Delete
    Next i
    With Cells
        .ClearContents
        .Font.Color = vbBlack
        .Font.Underline = False
        .Font.Bold = False
    End With
End Function

[SamT]

Try
RefersToR1C1:="='" & ActiveSheet.Name & "'!R" & .Row & "C" & .Column

Single quotes around the sheet name

[bantam]

SamT,

I was hoping that it was something easy like that. This macro not works as intended!

Thanks so much for the tip! How do I mark this as solved?

[Paul_Hossler]

This macro not works as intended!

My keyboard makes the same mistakes

Above your first post, there's [Thread Tools], and a [Mark this thread as solved ...] option button