[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Loop through all Folders and SubFolders

Posted on 2014-03-06
6
Medium Priority
?
301 Views
Last Modified: 2014-03-27
Good evening,

How can I change the following code to select a folder and look for all *.data files within that folder and subfolders?

Thank you!


Sub DoIt()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
    
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    'Set fld = Application.FileDialog(msoFileDialogFolderPicker)
        'open file picker instead of a folder picker
    Set fld = Application.FileDialog(msoFileDialogFilePicker)
    
        'set file picker dialog preferences
    With fld
        .Title = "Pick your file type"
        .AllowMultiSelect = False
            'you may want to comment out the next two lines if you want to allow users to select a variety of file types
        .Filters.Clear
        .Filters.Add "Text Files", "*.data"
        If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1)
    End With
    
    'sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
        'set file type based upon what the user has selected
    sTxtFilename = "*." & Right(sFolderLoc, Len(sFolderLoc) - InStrRev(sFolderLoc, "."))
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

        'set folder based upon location of file user has selected
    sFolderLoc = Left(sFolderLoc, InStrRev(sFolderLoc, "\"))

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & "\" & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & "\" & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
    
Exit_DoIt:
    Set fld = Nothing
    
End Sub

Open in new window

0
Comment
Question by:crepe
  • 3
  • 2
6 Comments
 
LVL 31

Expert Comment

by:gowflow
ID: 39911839
is this what you want ?


Sub DoIt1()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
    
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
        'open file picker instead of a folder picker
    'Set fld = Application.FileDialog(msoFileDialogFilePicker)
    
        'set file picker dialog preferences
    With fld
        .Title = "Pick your Folder"
        .AllowMultiSelect = False
            'you may want to comment out the next two lines if you want to allow users to select a variety of file types
        '.Filters.Clear
        '.Filters.Add "Text Files", "*.data"
        .Show
        'If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1) & "\*.data"
    End With
    
    sTxtFilename = Dir(sFolderLoc)
    
    'sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
        'set file type based upon what the user has selected
    sTxtFilename = "*." & Right(sFolderLoc, Len(sFolderLoc) - InStrRev(sFolderLoc, "."))
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

        'set folder based upon location of file user has selected
    sFolderLoc = Left(sFolderLoc, InStrRev(sFolderLoc, "\"))

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & "\" & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & "\" & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
    
Exit_DoIt:
    Set fld = Nothing
    
End Sub

Open in new window



gowflow
0
 

Author Comment

by:crepe
ID: 39912060
Almost! I also want it to check all subfolders within the selected folder.
0
 
LVL 31

Accepted Solution

by:
gowflow earned 2000 total points
ID: 39912954
Well this is a different ball game altogether, as Dir function has a problem and cannot the way your code was designed to get the Subfolders effectively.

Here is a Function that works recursively that will collect for a certain selected folder all the files and subfolders for a certain type of files here "*.data"

So below you will find the Function and below it you will find the modified Code that will give you want you want.

Public Function RecursiveDir(colFiles As Collection, _
                              strFolder As String, _
                              strFileSpec As String, _
                              bIncludeSubfolders As Boolean)

     Dim strTemp As String
     Dim colFolders As New Collection
     Dim vFolderName As Variant

     'Add files in strFolder matching strFileSpec to colFiles
     strFolder = TrailingSlash(strFolder)
     strTemp = Dir(strFolder & strFileSpec)
     Do While strTemp <> vbNullString
         colFiles.Add strFolder & strTemp
         strTemp = Dir
     Loop

     If bIncludeSubfolders Then
         'Fill colFolders with list of subdirectories of strFolder
         strTemp = Dir(strFolder, vbDirectory)
         Do While strTemp <> vbNullString
             If (strTemp <> ".") And (strTemp <> "..") Then
                 If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                     colFolders.Add strTemp
                 End If
             End If
             strTemp = Dir
         Loop

         'Call RecursiveDir for each subfolder in colFolders
         For Each vFolderName In colFolders
             Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
         Next vFolderName
     End If

End Function


Public Function TrailingSlash(strFolder As String) As String
     If Len(strFolder) > 0 Then
         If Right(strFolder, 1) = "\" Then
             TrailingSlash = strFolder
         Else
             TrailingSlash = strFolder & "\"
         End If
     End If
End Function

Open in new window



Here  is your modified Sub that will works with this Recursive function.

Sub DoIt3()
'---> This sub will loop for all files of type *.data files within that folder and all its Subfolders

    Dim fld As FileDialog
    Dim iCurrentRow As Long

    Dim J As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum
    Dim colFiles As New Collection
    Dim vFile As Variant
    
    
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
        'open folder picker instead of a folder picker
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
        'open file picker instead of a folder picker
    'Set fld = Application.FileDialog(msoFileDialogFilePicker)
    
        'set file picker dialog preferences
    With fld
        .Title = "Pick your Folder"
        .AllowMultiSelect = False
            'you may want to comment out the next two lines if you want to allow users to select a variety of file types
        '.Filters.Clear
        '.Filters.Add "Text Files", "*.data"
        .Show
        If fld.SelectedItems.Count = 0 Then
            GoTo Exit_DoIt
        Else
            sFolderLoc = fld.SelectedItems(fld.SelectedItems.Count)
        End If
    End With
    
    '---> Get the Recursive Files and folders
    RecursiveDir colFiles, sFolderLoc, "*.data", True
    
    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "
 
    For Each vFile In colFiles
      
        
        iCurrentRow = iCurrentRow + 1

        Open vFile For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = vFile
        Close #1
        J = J + 1
    Next vFile

UsedRange.EntireColumn.AutoFit

MsgBox ("A total of " & J & " *.data files analysed successfully.")
Set fld = Nothing
Exit Sub

Exit_DoIt:
    MsgBox ("No files were selected")
    Set fld = Nothing
    
End Sub

Open in new window


Let me know your comments.
gowflow
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 39

Expert Comment

by:nutsch
ID: 39912962
Hi crepe,

try this update, with a subfolder function:

Sub DoIt1()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum, myArr, lSubLoop As Long

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
    
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
        'open file picker instead of a folder picker
    'Set fld = Application.FileDialog(msoFileDialogFilePicker)
    
        'set file picker dialog preferences
    With fld
        .Title = "Pick your Folder"
        .AllowMultiSelect = False
            'you may want to comment out the next two lines if you want to allow users to select a variety of file types
        '.Filters.Clear
        '.Filters.Add "Text Files", "*.data"
        .Show
        'If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1)
    End With
    
myArr = GetSubFolders(sFolderLoc)
Set wbk1 = Workbooks.Add


For lSubLoop = LBound(myArr) To UBound(myArr)
    
    sTxtFilename = Dir(sFolderLoc & "\" & myArr(lSubLoop) & "\*.data")
    
    'sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
        'set file type based upon what the user has selected
    sTxtFilename = "*." & Right(sFolderLoc, Len(sFolderLoc) - InStrRev(sFolderLoc, "."))
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & "\" & myArr(lSubLoop) & "\" & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & "\" & myArr(lSubLoop) & "\" & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
    
Next lSubLoop
    
Exit_DoIt:
    Set fld = Nothing
    
End Sub
                                            
Function GetSubFolders(RootPath As String)
'function plundered from Patrick Matthews, EE comment 19880728
    Dim arr() As String
    Dim FSO As Object
    Dim fld As Object
    Dim sf As Object
    Dim Counter As Long
   
   On Error Resume Next
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(RootPath)
    ReDim arr(1 To fld.SubFolders.Count) As String
    For Each sf In fld.SubFolders
        Counter = Counter + 1
        arr(Counter) = sf.Name
    Next

    GetSubFolders = arr

    Set sf = Nothing: Set fld = Nothing: Set FSO = Nothing

End Function

Open in new window

0
 

Author Closing Comment

by:crepe
ID: 39959303
Worked perfectly! Thank you.
0
 
LVL 31

Expert Comment

by:gowflow
ID: 39959477
your welcome.
gowflow
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

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 how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

834 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