Solved

Loop through all Folders and SubFolders

Posted on 2014-03-06
6
266 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 29

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 29

Accepted Solution

by:
gowflow earned 500 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
3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

 
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 29

Expert Comment

by:gowflow
ID: 39959477
your welcome.
gowflow
0

Featured Post

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Excel VBA User Form Help 21 29
Excel VBA - triggering a Sheet event on another workbook 3 29
And OR formula 5 24
Creating An Intelligent Dropdown 8 30
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

832 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