How to pull file structure into excel with VBA

Jumparound

New Member
Joined
Aug 4, 2015
Messages
45
Office Version
  1. 2016
Platform
  1. Windows
Hi,

We've got a fairly complex file structure and I would like to create an index for it in Excel. I've played about with getting the information out of DOS but it's quite messy and I wonder if VBA could be used to speed up the process. I found the below code online which seems to work quite well (I'm not able to write my own, too dumb:confused:). However it only takes the info from my documents and I would like to specify another drive. I can't see where in the code it is getting the instruction for where to pull the information from. Can anyone help?

I also wondered secondly if there was a simple way to make the files links too in VBA? Might not be a straightforward task and not as important.


Code:
Option Explicit


Const ShowLevels As Integer = 2


Public Sub showAll()
    If ActiveSheet.UsedRange.Rows.Count > 1 Then ActiveSheet.Range("2:" & ActiveSheet.UsedRange.Rows.Count).Delete
    Application.ScreenUpdating = False
    Range("A1").Activate
    showDirs ActiveCell.Value, ShowLevels
    Application.ScreenUpdating = True
    ActiveSheet.Outline.ShowLevels RowLevels:=2 ' show 1st level subfolders and files
End Sub


Private Sub showDirs(pm_Path As String, pm_Level As Integer)
    Dim sDirEntry, arrDirEntries(), maxd
    maxd = -1
    ActiveCell.Offset(1, 1).Activate
    Dim savecell: Set savecell = ActiveCell
    On Error Resume Next
    sDirEntry = Dir(pm_Path, vbDirectory Or vbNormal Or vbHidden)
    If Err.Number <> 0 Then GoTo oops ' oops1
    While sDirEntry <> ""
        If sDirEntry <> "." And sDirEntry <> ".." Then
            maxd = maxd + 1
            ReDim Preserve arrDirEntries(maxd)
            arrDirEntries(maxd) = sDirEntry
        End If
        sDirEntry = Dir()
        If Err.Number <> 0 Then GoTo oops ' oops2
    Wend
    If maxd = -1 Then
        ' empty
    Else
        Dim at
        For maxd = 0 To UBound(arrDirEntries)
            at = GetAttr(pm_Path & arrDirEntries(maxd)) And 31 ' not interested in archive (32) and higher, encrypted/compressed
            If (at And vbHidden) = vbHidden Then ActiveCell.Font.Italic = True
            'If (at And vbAlias) = vbAlias Then ActiveCell.Font.Color = vbGreen
            'If (at And vbReadOnly) = vbReadOnly Then ' ...
            If (at And vbDirectory) = vbDirectory Then
                ActiveCell.Value = arrDirEntries(maxd)
                ActiveCell.Font.Bold = True
                If pm_Level > 0 Then
                    showDirs pm_Path & arrDirEntries(maxd) & "\", pm_Level - 1
                    ActiveCell.Offset(0, -1).Activate
                Else
                    ActiveCell.Offset(1, 0).Activate
                End If
            End If
        Next
        For maxd = 0 To UBound(arrDirEntries)
            at = GetAttr(pm_Path & arrDirEntries(maxd)) And 31
            If (at And vbHidden) = vbHidden Then ActiveCell.Font.Italic = True
            If (at And vbDirectory) = 0 Then
                ActiveCell.Value = arrDirEntries(maxd)
                ActiveCell.Offset(1, 0).Activate
            End If
        Next
        Range(savecell, ActiveCell.Offset(-1, 0)).Rows.Group
    End If
    GoTo done
oops:
    ActiveCell.Offset(-1, -1).Font.Color = vbRed ' access denied
done:
    Set savecell = Nothing
End Sub

Thank you!
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
I managed to do this using DOS and a bit of cutting and pasting in the end. Using HYPERLINK and CONCATENATE I was able to change them to links.
 
Upvote 0

Forum statistics

Threads
1,213,496
Messages
6,113,993
Members
448,539
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top