?
Solved

Bold Enumerated Folders, Rename Sheet

Posted on 2012-04-13
3
Medium Priority
?
249 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 2000 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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This article describes a serious pitfall that can happen when deleting shapes using VBA.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
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…

764 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