Solved

Bold Enumerated Folders, Rename Sheet

Posted on 2012-04-13
3
233 Views
Last Modified: 2012-04-16
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

0
Comment
Question by:Cook09
  • 2
3 Comments
 
LVL 81

Expert Comment

by:byundt
ID: 37845059
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
 
LVL 81

Accepted Solution

by:
byundt earned 500 total points
ID: 37845091
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
 

Author Closing Comment

by:Cook09
ID: 37851108
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

Featured Post

Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Determine dependencies 3 21
Excel formula that pulls back the id 4 42
need 2017 datas one by one using macro 12 38
Excel VBA Sort Toggle 5 9
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Having trouble getting your hands on Dynamics 365 Field Service or Project Service trial? Worry No More!!!
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

726 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question