PDA

View Full Version : [SOLVED] Directory mapping macro - need more robust code



bantam
06-16-2016, 07:29 AM
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
06-16-2016, 08:06 AM
Try
RefersToR1C1:="='" & ActiveSheet.Name & "'!R" & .Row & "C" & .Column

Single quotes around the sheet name

bantam
06-16-2016, 10:26 AM
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
06-16-2016, 12:16 PM
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