[2 days left] What’s wrong with your cloud strategy? Learn why multicloud solutions matter with Nimble Storage.Register Now

x
?
Solved

Loop through all Folders and SubFolders

Posted on 2014-03-06
6
Medium Priority
?
293 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
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

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

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

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

649 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