• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 313
  • Last Modified:

Loop through all Folders and SubFolders

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
crepe
Asked:
crepe
  • 3
  • 2
1 Solution
 
gowflowCommented:
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
 
crepeAuthor Commented:
Almost! I also want it to check all subfolders within the selected folder.
0
 
gowflowCommented:
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
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
nutschCommented:
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
 
crepeAuthor Commented:
Worked perfectly! Thank you.
0
 
gowflowCommented:
your welcome.
gowflow
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now