Directory Listing and Some Formatting

[pdevadiga]

Hi,
This is my first post ....I have a task in hand which prompted me to come over here & indeed
I was rewarded but I have some more issues...though I never gave a thought of macro nor I have any experience in doing so.....
First of all what got sorted out by venturing here.
1) I was told to maintain a directory structure in excel with subfolders including files.That code I was able to get it from here.
The Problem:
I got the directory listed as said but now they do not want the Subfolder's path to be listed
but instead they want it to be highlighted in bold in some color for each column say for example column B has 10 files (For e.g. abc.xls, abc.doc, abc.pdf etc) and 4 SubFolders (For e.g. D:\Test\Test\Test\Sub1 etc) they want the 10 files to be as it is and the Sub
Folder in this case to be bold and in some color say red and Italic and the path removed like Sub1.. this they want in every column say in column C the same logic but with different color.
Like this I have a tree from Column A to Column I.
Any ideas from gurus how to achive this.

Prashant

 

[AlphaFrog]

Can you post the code for your macro?

Forum Tip: Pasting VBA code in the forum editor:
It would be best if you surround your VBA code with code tags e.g [CODE]your VBA code here[/CODE]
It makes reading your VBA code much easier. When you're in the forum editor, highlight your pasted VBA code and then click on the icon with the pound or number sign #.

 

[pdevadiga]

Thanks for replying AlphaFrog ....This code I have got it from here itself...but I was given a further task which is why
I thought this woud be the best place to ask for help..Anyways here's the code

Option Explicit
Sub doADirectory(whatDir As String, OutputCell As Range)
    Dim aFileName As String, FullName As String, i As Integer
    ReDim FolderList(1 To 1) As String
    
    aFileName = Dir(whatDir, &H1F)
        'cheating a bit here; look up DIR in XL VBE help for 2nd argument
    OutputCell.Value = whatDir
    Set OutputCell = OutputCell.Offset(1, 1)
    Do While aFileName <> ""
        If aFileName = "." Or aFileName = ".." Then
        Else
            FullName = whatDir & aFileName
            If (GetAttr(FullName) _
                And vbDirectory) = vbDirectory Then
                ReDim Preserve FolderList(LBound(FolderList) To UBound(FolderList) + 1)
                FolderList(UBound(FolderList)) = aFileName
            Else
                OutputCell.Value = aFileName
                Set OutputCell = OutputCell.Offset(1, 0)
                End If
            End If
        aFileName = Dir
        Loop
    For i = LBound(FolderList) + 1 To UBound(FolderList)
        doADirectory whatDir & FolderList(i) & Application.PathSeparator, OutputCell
        Set OutputCell = OutputCell.Offset(0, -1)
        Next i
    End Sub
Sub startADir()
    doADirectory "D:\data\Test\", Range("a1")
    End Sub

 

[AlphaFrog]

Sub doADirectory(whatDir As String, OutputCell As Range)

    Dim aFileName As String, FullName As String, i As Integer
    
    ReDim FolderList(1 To 1) As String
    
    aFileName = Dir(whatDir, &H1F)
        'cheating a bit here; look up DIR in XL VBE help for 2nd argument
[COLOR="Red"]    With OutputCell
        .Value = Mid(whatDir, InStrRev(whatDir, Application.PathSeparator, Len(whatDir) - 1) + 1)
        .HorizontalAlignment = xlRight
        With .Font
            .Name = "Arial"
            .Size = 11
            .Bold = True
            .Italic = True
            .ColorIndex = 3 'red
    End With: End With[/COLOR]
    Set OutputCell = OutputCell.Offset(1, 1)
    Do While aFileName <> ""
        If aFileName = "." Or aFileName = ".." Then
        Else
            FullName = whatDir & aFileName
            If (GetAttr(FullName) _
                And vbDirectory) = vbDirectory Then
                ReDim Preserve FolderList(LBound(FolderList) To UBound(FolderList) + 1)
                FolderList(UBound(FolderList)) = aFileName
            Else
                OutputCell.Value = aFileName
                Set OutputCell = OutputCell.Offset(1, 0)
            End If
        End If
        aFileName = Dir
        Loop
    For i = LBound(FolderList) + 1 To UBound(FolderList)
        doADirectory whatDir & FolderList(i) & Application.PathSeparator, OutputCell
        Set OutputCell = OutputCell.Offset(0, -1)
        Next i
    End Sub
    
Sub startADir()
    ' Range("A:E").Clear
    [COLOR="Red"]Application.ScreenUpdating = False[/COLOR]
    doADirectory "D:\data\Test\", Range("A1")
    [COLOR="Red"]Application.ScreenUpdating = True[/COLOR]
End Sub

 

[pdevadiga]

Magnificient Sir....how do you do it....Amazing...I really appreciate ur effort AlphaFrog....One thing though the folder names ends with a slash "\"...can it be removed if possible otherwise its OK... May I be more greedy.. May I have another worksheet stating only the Folders & SubFolders without files like tcolors ...something like a TOC based on this Worksheet...Something very cosmetic/colorful type of....

I would be really grateful..

Thanks a ton...

 

[AlphaFrog]

You're welcome.

I had intentionally left in the trailing slash. I thought it looked better that way. If you want it removed...

Replace this...

.Value = Mid(whatDir, InStrRev(whatDir, Application.PathSeparator, Len(whatDir) - 1) + 1)

With this...

.Value = Replace(Mid(whatDir, InStrRev(whatDir, Application.PathSeparator, Len(whatDir) - 1) + 1), Application.PathSeparator, "")

The code below will list just Folders\subfolders. You'll have to figure out the "something very cosmetic/colorful" thing yourself. There are several macros\utilities out there that do this sort of thing. Perhaps you may find one that's more flexible. Do a web search for something like; Excel macro directory list .

Sub startATOC()
    Range("A:E").Clear
    Application.ScreenUpdating = False
    doATOC "D:\data\Test\", Range("A1")
    Application.ScreenUpdating = True
End Sub

Sub doATOC(whatDir As String, OutputCell As Range)

    Dim aFileName As String, FullName As String, i As Integer
    
    ReDim FolderList(1 To 1) As String
    
    aFileName = Dir(whatDir, &H1F)
        'cheating a bit here; look up DIR in XL VBE help for 2nd argument
    With OutputCell
        .Value = Replace(Mid(whatDir, InStrRev(whatDir, Application.PathSeparator, Len(whatDir) - 1) + 1), Application.PathSeparator, "")
        .HorizontalAlignment = xlRight
        With .Font
            .Name = "Arial"
            .Size = 11
            .Bold = True
            .Italic = True
            .ColorIndex = 3 'red
    End With: End With
    Set OutputCell = OutputCell.Offset(1, 1)
    Do While aFileName <> ""
        If aFileName = "." Or aFileName = ".." Then
        Else
            FullName = whatDir & aFileName
            If (GetAttr(FullName) _
                And vbDirectory) = vbDirectory Then
                ReDim Preserve FolderList(LBound(FolderList) To UBound(FolderList) + 1)
                FolderList(UBound(FolderList)) = aFileName
            Else
[COLOR="Green"]                'OutputCell.Value = aFileName
                'Set OutputCell = OutputCell.Offset(1, 0)[/COLOR]
            End If
        End If
        aFileName = Dir
        Loop
    For i = LBound(FolderList) + 1 To UBound(FolderList)
        doATOC whatDir & FolderList(i) & Application.PathSeparator, OutputCell
        Set OutputCell = OutputCell.Offset(0, -1)
        Next i
    End Sub

 

[pdevadiga]

Thank You Sir ...U made my day...

Regards,
Prashant

 

[pdevadiga]

Hey AlphaFrog,

Just wondering can the second part ..the TOC one be hyerlinked with the above worksheet. Both the worksheets reside in the same workbook..Wonder if that is possible ?

Regards,
Prashant