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

Cook09Asked:
Who is Participating?
 
byundtConnect With a Mentor Commented:
If you also want to rename the worksheet with the main folder name and bold any subfolders found, then here is the macro with those additional tweaks:

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
                    'Test whether strFName is subfolder or file
                On Error Resume Next
                If GetAttr(strDirectory & strFName) = vbDirectory Then ActiveCell.Offset(iRow).Font.Bold = True
                On Error GoTo 0
                iRow = iRow + 1
            End Select
            strFName = Dir
        Loop
        strDirectory = Left(strDirectory, Len(strDirectory) - 1)
        strDirectory = Mid(strDirectory, InStrRev(strDirectory, Application.PathSeparator) + 1)
        Range("A1").Value = strDirectory
        Range("A1").Font.Bold = True
        ActiveSheet.Name = strDirectory
        ActiveWindow.DisplayGridlines = False
        Range("A1").EntireColumn.AutoFit
    End If
End With
End Sub

Open in new window


Brad
0
 
byundtCommented:
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
0
 
Cook09Author Commented:
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.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.