asked on

Bold Enumerated Folders, Rename Sheet

I'm using the following code to list items within a particular folder or subfolder. What I would like to do, is Bold the Folders that are enumerated while leaving the files normal, to easily see what is a document or not.

The second thing is to rename the sheet with the actual subdirectory Name only, instead of the path that is being enumerated? Or, Maybe there is an easier way to manage all of the code documents that have been collected over the years.

Sub GetFileNames()
Dim iRow As Integer
Dim strDirectory As String, strFName As String, strInitialFoldr As String

iRow = 1
Range("A1").Activate
     With Application.FileDialog(msoFileDialogFolderPicker)
           .Show
           strDirectory = .SelectedItems(1) & "\"
             strInitialFoldr = strDirectory
      End With

     With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Now….Please select a  *Folder*  to list Files from"
         .InitialFileName = strInitialFoldr
       .Show
             If .SelectedItems.Count <> 0 Then
                 strDirectory = .SelectedItems(1) & "\"
                  strFName = Dir(strDirectory, 16)
                          Do While strFName <> ""
                            ActiveCell.Offset(iRow) = strFName
                            iRow = iRow + 1
                            strFName = Dir
                         Loop
      Range("A1") = strDirectory
      ActiveWindow.DisplayGridlines = False
      Range("A1").EntireColumn.AutoFit
  End If
 End With
End Sub

Open in new window

byundt

If I understand you correctly, the following tweaks to your code will make the folder name bold, with the file names in Roman. I also eliminated the . and .. at the top of the list.

Sub GetFileNames()
Dim iRow As Integer
Dim strDirectory As String, strFName As String, strInitialFoldr As String

iRow = 1
Range("A1").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    strDirectory = .SelectedItems(1) & "\"
    strInitialFoldr = strDirectory
End With

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Now….Please select a  *Folder*  to list Files from"
    .InitialFileName = strInitialFoldr
    .Show
     If .SelectedItems.Count <> 0 Then
        strDirectory = .SelectedItems(1) & "\"
        strFName = Dir(strDirectory, 16)
        Do While strFName <> ""
            Select Case strFName
            Case ".", ".."
            Case Else
                ActiveCell.Offset(iRow) = strFName
                iRow = iRow + 1
            End Select
            strFName = Dir
        Loop
        strDirectory = Left(strDirectory, Len(strDirectory) - 1)
        Range("A1") = Mid(strDirectory, InStrRev(strDirectory, Application.PathSeparator) + 1)
        Range("A1").Font.Bold = True
        ActiveWindow.DisplayGridlines = False
        Range("A1").EntireColumn.AutoFit
    End If
End With
End Sub

Open in new window

Brad

ASKER CERTIFIED SOLUTION

byundt

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Cook09

ASKER

Exactly what I wanted with this question. Thanks Brad. I do have one more item to add to this code, but I'll post it as a seperate question, as it may require a little more thought.