Using Dir() and Searching SubFolders

srcera

Board Regular
Joined
May 22, 2006
Messages
95
I have the following code in which I want to return all the files in the directory however, all the files are in sub-folders (which I need to keep). Therefore it returns the message. How do I change it to return all the files in the subfolders?

Thanks,


'segpath is "C:\" and a folder name
ChDrive segpath
ChDir segpath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

svg109

Board Regular
Joined
Mar 1, 2005
Messages
64
Hello srcera

I have written similar code to return all the files in a specified folder.

Do you want to display the files in a workbook or only in a message box?

Can you give me some details? Maybe I can quickly modify my code for you.

You will need MS scripting runtime added to your references though..

SG
 

srcera

Board Regular
Joined
May 22, 2006
Messages
95
I want to open up the files, take data out of each of the files, and then post the data with calculations in the workbook containing the code.
 

bsnapool

Active Member
Joined
Jul 10, 2006
Messages
452
I have the following code, which prompts to look at a tab within a folder list, and extratcs rows of data if any data is within range...

Worth a look:

Code:
Option Explicit
Dim wsLog As Worksheet
Sub SummaryNoTots()
Dim sWeeks() As String, sList As String
Dim iWeekPtr As Integer, iPtr As Integer
Dim iWkCur As Integer, iWkLow As Integer, iWkHigh As Integer
Dim wsSumm As Worksheet, WS As Worksheet, wsPWD As Worksheet
Dim Folderpath As String, Filenm As String
Dim I As Long, R As Long, C As Long, lRowTo As Long, lRowEnd As Long
Dim lRowStart As Long, lRowCU As Long, lErrNum As Long
Dim sPassword As String
Dim V As Variant, ChWeek As Variant, vFileList As Variant
Dim Bcol As Range
Dim firstAddress As String
Set wsSumm = ThisWorkbook.Sheets("Summary") ' Should be defined as ThisWorkbook
Set wsLog = ThisWorkbook.Worksheets("Activity Log") ' Should be defined as ThisWorkbook
Set wsPWD = ThisWorkbook.Sheets("Passwords") ' Should be defined as ThisWorkbook


'Look in this file path to get a list of files in the folder, change this as required
Folderpath = ThisWorkbook.Path
Filenm = Dir(Folderpath & "\*.xls", vbNormal + vbReadOnly)

vFileList = GetFileList(Folderpath & "/*.xls")

If IsArray(vFileList) = False Then
    MsgBox "No Excel files found in " & Folderpath & vbCrLf & _
            "Macro abandoned."
    Exit Sub
End If

ChWeek = Application.InputBox(prompt:="Enter Week(s) required separated by comma" & vbCrLf & _
                                    "(e.g. 1,2,3,4)..." & vbCrLf & _
                                      "... or 'Cancel' to exit.", _
                              Type:=2)

If ChWeek = False Then Exit Sub

sWeeks = Split(ChWeek, ",")
iWkLow = 999
For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
    iWkCur = Val(sWeeks(iWeekPtr))
    If iWkCur < 1 Or iWkCur > 52 Then
        MsgBox "Invalid Week number entered"
        Exit Sub
    End If
    If iWkCur < iWkLow Then iWkLow = iWkCur
    If iWkCur > iWkHigh Then iWkHigh = iWkCur
Next iWeekPtr

With wsSumm
    lRowTo = .UsedRange.Row + .UsedRange.Rows.Count - 1
    If lRowTo > 2 Then .Rows("5:" & lRowTo).ClearContents
    lRowTo = .Cells(Rows.Count, "B").End(xlUp).Row + 1
End With

With Application
    .ScreenUpdating = False
    'Ensure macros dont fire when opening w/books
    .EnableEvents = False
End With

For I = LBound(vFileList) To UBound(vFileList)
    Filenm = vFileList(I)

    If ThisWorkbook.Name <> Filenm Then
        
        'Paste the name
        lRowTo = lRowTo + 3
        wsSumm.Cells(lRowTo, "A").Value = Filenm
        
        lRowStart = lRowTo + 1
        
        'open File
        V = "*"
        On Error Resume Next
        V = WorksheetFunction.Match(Filenm, wsPWD.Columns("A"), 0)
        On Error GoTo 0
        If IsNumeric(V) Then
            sPassword = wsPWD.Cells(V, "B").Text
        Else
            sPassword = ""
        End If
        On Error Resume Next
        Workbooks.Open FileName:=Folderpath & "\" & Filenm, _
                        ReadOnly:=True, _
                        Password:=sPassword
        lErrNum = Err.Number
        On Error GoTo 0
        If lErrNum > 0 Then
            LogEntry ExcelFile:=Filenm, _
                     Week:="******", _
                     Message:="CANNOT OPEN"
        Else
            For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
                Set WS = Nothing
                On Error Resume Next
                Set WS = Sheets(sWeeks(iWeekPtr))
                On Error GoTo 0
                If Not WS Is Nothing Then
                    If WS.Tab.ColorIndex = xlColorIndexNone Then
                        lRowTo = lRowTo + 1
                        With wsSumm
                            .Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
                            .Cells(lRowTo, "B").Value = "NOT UPDATED"
                        End With
                        LogEntry ExcelFile:=Filenm, _
                                 Week:="Week " & sWeeks(iWeekPtr), _
                                 Message:="NOT UPDATED"
                    Else
                        Application.StatusBar = "Processing " & Filenm & ": Week " & _
                                                sWeeks(iWeekPtr)
                        
                        'Check Range
                        'Get last row to check
                        'lRowEnd = WS.Range("B" & Rows.Count).End(xlUp)' --->>> Removed not working due to
     ' This last row detect was not really being detected correctly  as there was some other data down row 222 in col B workbook AEA
     
    '------------------Find the which row total is in in the data source------
    ' Searches for Total…in Col B and set LrowEnd to one row less
    'NOTE - becareful not put more than one "TOTAL" or "total" or "Total" _
     or other combination in Col B of you sheets you get the data from.
                                With WS.Range("B12:B65336")
                                       Set Bcol = .Find(LCase("TOTAL"), LookIn:=xlValues)
                                       If Not Bcol Is Nothing Then
                                           firstAddress = Bcol.Address
                                Do
                                lRowEnd = Bcol.Row - 1 ' set one row less than cell with "TOTAL"
                              
                                Set Bcol = .FindNext(Bcol)
                                Loop While Not Bcol Is Nothing And Bcol.Address <> firstAddress
                                End If
                                End With

                       '===========Start of looking for the entries to copy ==========
                       
                        For R = 12 To lRowEnd ' For  Rows of 12 to last
                            If LCase$(WS.Cells(R, "B").Text) <> "Total" Then ' if the entry in Row B is not = Total
                               ' For C = 6 To 7 'Cols F:L ' ===> Removed DOING NOTHING
                                 
                                   If Application.CountA(WS.Range(WS.Cells(R, 6), WS.Cells(R, 12))) Or _
                                        Application.CountA(WS.Range(WS.Cells(R, 14), WS.Cells(R, 18))) _
                                        Then 'If there is entry in col F to L  or N to S copy the row to Summary
     
                                        lRowTo = lRowTo + 1 'last used row in the summary +1
                                        With wsSumm ' the copy
                                            .Rows(lRowTo).Value = WS.Rows(R).Value
                                            .Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
                                            
                                        End With
                                     Else   'Exit For '===> Removed DOING NOTHING
                                    End If
                              Else
                               'Next C '===> Removed DOING NOTHING
                            End If
                        Next R
                         LogEntry ExcelFile:=Filenm, _
                                 Week:="Week " & sWeeks(iWeekPtr), _
                                 Message:="PROCESSED"
                    End If
                Else
                    lRowTo = lRowTo + 1
                    With wsSumm
                        .Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
                        .Cells(lRowTo, "B").Value = "NOT FOUND"
                    End With
                   LogEntry ExcelFile:=Filenm, _
                            Week:="Week " & sWeeks(iWeekPtr), _
                            Message:="NOT FOUND"
                End If
            Next iWeekPtr
        
            'lRowTo = lRowTo + 2
           ' wsSumm.Cells(lRowTo, "B").Value = "TOTAL"
           ' For iPtr = 1 To 7
           '     wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
            'Next iPtr
            'wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
            With Application
                .DisplayAlerts = False
                ActiveWorkbook.Close
                .DisplayAlerts = True
            End With
        End If
    End If
Next I
    
'lRowTo = lRowTo + 2
'wsSumm.Cells(lRowTo, "B").Value = "GRAND TOTAL"
'For iPtr = 1 To 7
 '   wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R4C:R[-1]C)/2"
'Next iPtr
'wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R4C:R[-1]C)/2"
  
With Application
    .StatusBar = False
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Function GetFileList(FileSpec As String) As Variant
'  Courtesy John Walkenbach
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound

    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function

'   Error handler
NoFilesFound:
    GetFileList = False
End Function

Sub LogEntry(ByVal ExcelFile As String, _
             ByVal Week As String, _
             ByVal Message As String)
Dim lRow As Long
Dim vData(1 To 4) As Variant

lRow = wsLog.Cells(Rows.Count, "A").End(xlUp).Row + 1
vData(1) = Format(Now(), "dd-mmm-yy hh:mm:ss")
vData(2) = ExcelFile
vData(3) = Week
vData(4) = Message
wsLog.Range("A" & lRow & ":D" & lRow).Value = vData
End Sub
 

srcera

Board Regular
Joined
May 22, 2006
Messages
95
I took the following lines from your code and then changed some variables

GetFileList function
vFileList = GetFileList(Folderpath & "/*.xls")
If IsArray(vFileList) = False Then
MsgBox "No Excel files found in " & Folderpath & vbCrLf & _
"Macro abandoned."
Exit Sub
End If
Filenm = vFileList(I)

But, I am stuck with the same problem, I started with. The msgbox comes up because the files are not in that folder but in several subfolders, which I need to keep.
So instead of

vFileList = GetFileList(Folderpath & "/*.xls")

It would be something like

vFileList = GetFileList(Folderpath & "/*/*/*/*.xls")

but that doesn't work either.

Thanks
 

svg109

Board Regular
Joined
Mar 1, 2005
Messages
64
Srcera

Sorry I thought you only wanted to find file-information about all the files that you have.

This following code may work for with some modifications: note that you need to add MS scripiting runtime to your references for this to work.

I found this code on Erlandsen's website and had modified it for my purpose a long time ago. (once again thank you Ole)

Code:
Sub ListALLFilesInFolder()
Dim namefilepath As String

ActiveSheet.Select
ActiveCell.Select

    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Full File Name:"
    Range("B3").Formula = "File Name:"
    Range("C3").Formula = "File Size:"
    Range("D3").Formula = "File Type:"
    Range("E3").Formula = "Date Created:"
    Range("F3").Formula = "Date Last Accessed:"
    Range("G3").Formula = "Date Last Modified:"
 
    Range("A2").Font.Bold = True
    
' ****ENTER THE FOLDER PATH****

namefilepath = InputBox("Enter the Folder Path", , "C:\Temp")
Range("A2").Value = namefilepath
    
    ListFilesInFolder namefilepath, True
    ' list all files included subfolders
Exit Sub
errhndlr:

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim fileitem As Scripting.File
Dim r As Long
Dim numf As Integer
Dim WB As Workbooks
numf = 0
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("B65536").End(xlUp).Row + 2
    For Each fileitem In SourceFolder.Files
        
If fileitem.Type = "Microsoft Excel Worksheet" Then   'This is where you need to change the code to get your data...
        Workbooks.Open fileitem
        
        'Right now this code only gets the attributes and creates a list inthe main workbook
        Cells(r, 2).Formula = fileitem.Name
        Cells(r, 3).Formula = fileitem.Size
        Cells(r, 4).Formula = fileitem.Type
        Cells(r, 5).Formula = fileitem.DateCreated
        Cells(r, 6).Formula = fileitem.DateLastAccessed
        Cells(r, 7).Formula = fileitem.DateLastModified
        'Cells(r, 8).Formula = fileitem.Attributes
        'Cells(r, 9).Formula = fileitem.ShortPath & fileitem.ShortName
        
        
numf = numf + 1
Cells(r, 1) = numf
        r = r + 1 ' next row number
        
 End If
    Next fileitem
    
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
    Columns("B:K").AutoFit
    
      
    
    Set fileitem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub

The current code only returns file attibutes for the folder that you specify, but can easily be modified so that each excel file is opened and data retrieved from it and pasted to your original workbook.

Its a monday and there are too many meetings today....sorry could not modfiy the code a whole lot for you.

hope this helps...

-SG
 

Forum statistics

Threads
1,141,596
Messages
5,707,303
Members
421,502
Latest member
PULBAG

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
Top