Loop through folders and sub-folders to extract and save worksheets

I want to cycle through all workbooks in a folder and its sub-folders, extract worksheets named "Action", and save them as .csv files with the name of the file from which they originated.
I am trying to integrate two code routines one for recursive loop which chooses directory and other one for saving the file sheet and it loops through parent directory only.  My efforts have not succeeded as my command in VBA is not strong. I need this solution for excel 2007 and its resident VBE.
Look Forward to Experts Help.
The following routine lists all the file contained in the directory chosen by File Dialog System.
Sub GetFileListb()

    Dim strFolder As String
    Dim objFSO As Object
    Dim objFolder As Object
    Dim myResults As Variant
    Dim lCount As Long

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' Get the directory from the user
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        'user cancelled
        strFolder = .SelectedItems(1)
    End With

    Set objFolder = objFSO.GetFolder(strFolder)

    'the variable dimension has to be the second one
    ReDim myResults(0 To 5, 0 To 0)

    ' place make some headers in the array
    myResults(0, 0) = "Filename"
    myResults(1, 0) = "Size"
    myResults(2, 0) = "Created"
    myResults(3, 0) = "Modified"
    myResults(4, 0) = "Accessed"
    myResults(5, 0) = "Full path"

    'Send the folder to the recursive function
    FillFileListb objFolder, myResults, lCount

    ' Dump these to a worksheet
    fcnDumpToWorksheetb myResults

    'tidy up
    Set objFSO = Nothing

End Sub

Private Sub FillFileListb(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)

    Dim i As Integer
    Dim objFile As Object
    Dim fsoSubFolder As Object
    Dim fsoSubFolders As Object

    'load the array with all the files
    For Each objFile In objFolder.Files
        lCount = lCount + 1
        ReDim Preserve myResults(0 To 5, 0 To lCount)
        myResults(0, lCount) = objFile.Name
        myResults(1, lCount) = objFile.Size
        myResults(2, lCount) = objFile.DateCreated
        myResults(3, lCount) = objFile.DateLastModified
        myResults(4, lCount) = objFile.DateLastAccessed
        myResults(5, lCount) = objFile.Path
    Next objFile

    'recursively call this function with any subfolders
    Set fsoSubFolders = objFolder.SubFolders

    For Each fsoSubFolder In fsoSubFolders
        FillFileListb fsoSubFolder, myResults, lCount
    Next fsoSubFolder

End Sub

Private Sub fcnDumpToWorksheetb(varData As Variant, Optional mySh As Worksheet)

    Dim iSheetsInNew As Integer
    Dim sh As Worksheet, wb As Workbook
    Dim myColumnHeaders() As String
    Dim l As Long, NoOfRows As Long

    If mySh Is Nothing Then
        'make a workbook if we didn't get a worksheet
        iSheetsInNew = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        Set wb = Application.Workbooks.Add
        Application.SheetsInNewWorkbook = iSheetsInNew
        Set sh = wb.Sheets(1)
    Else
        Set mySh = sh
    End If

    'since we switched the array dimensions, have to transpose
    With sh
        Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
            Application.WorksheetFunction.Transpose(varData)

        .UsedRange.Columns.AutoFit
    End With

    Set sh = Nothing
    Set wb = Nothing

End Sub

Open in new window



The other routine to save the files as follows.
Sub LoopThroughFiles()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim strFolder As String
    Dim strFile As String

    strFolder = "c:\My dir"
    strFile = Dir(strFolder & "\*.xls*")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Do While Len(strFile) > 0
     Set Wb = Workbooks.Open(strFolder & "\" & strFile)
     Set ws = Nothing
     On Error Resume Next
     Set ws = Wb.Sheets("Action")
     On Error GoTo 0
     If Not ws Is Nothing Then ws.SaveAs Left$(Wb.FullName, InStrRev(Wb.FullName, ".")) & "csv", FileFormat:=xlCSV
     Wb.Close False
        strFile = Dir
    Loop

     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Open in new window

Sunil KakkarAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saurabh Singh TeotiaCommented:
To ensure i understand your request completely..You want to combine these 2 codes as one..correct me if i'm wrong??
0
Sunil KakkarAuthor Commented:
Hi Saurabh
Yes please I want these 2 codes to be combined as one. It may be treated as reference only as for a combined code, coding may have to be changed suitably. What I want is That Program gives me the choice to open the windows explorer to choose the  folder and then allow cycling through all workbooks in chosen folder and its sub-folders, extract worksheets named "Action", and save them as .csv files with the name of the file from which they originated. Files can be saved to either a specified directory or in their respective folders.
Hope it clarifies myrequirements. I tried to integrate these two programming code concepts but could not succeed. My level in VBA is of a beginner only.
0
Saurabh Singh TeotiaCommented:
You can simply use this to do what you are looking for...

Sub GetFileListb()

    Dim strFolder As String
    Dim objFSO As Object
    Dim objFolder As Object
    Dim myResults As Variant
    Dim lCount As Long

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' Get the directory from the user
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        'user cancelled
        strFolder = .SelectedItems(1)
    End With

    Set objFolder = objFSO.GetFolder(strFolder)

    'the variable dimension has to be the second one
    ReDim myResults(0 To 5, 0 To 0)

    ' place make some headers in the array
    myResults(0, 0) = "Filename"
    myResults(1, 0) = "Size"
    myResults(2, 0) = "Created"
    myResults(3, 0) = "Modified"
    myResults(4, 0) = "Accessed"
    myResults(5, 0) = "Full path"

    'Send the folder to the recursive function
    FillFileListb objFolder, myResults, lCount

    ' Dump these to a worksheet
    fcnDumpToWorksheetb myResults

    'tidy up
    Set objFSO = Nothing
    
    LoopThroughFiles

End Sub

Private Sub FillFileListb(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)

    Dim i As Integer
    Dim objFile As Object
    Dim fsoSubFolder As Object
    Dim fsoSubFolders As Object

    'load the array with all the files
    For Each objFile In objFolder.Files
        lCount = lCount + 1
        ReDim Preserve myResults(0 To 5, 0 To lCount)
        myResults(0, lCount) = objFile.Name
        myResults(1, lCount) = objFile.Size
        myResults(2, lCount) = objFile.DateCreated
        myResults(3, lCount) = objFile.DateLastModified
        myResults(4, lCount) = objFile.DateLastAccessed
        myResults(5, lCount) = objFile.Path
    Next objFile

    'recursively call this function with any subfolders
    Set fsoSubFolders = objFolder.SubFolders

    For Each fsoSubFolder In fsoSubFolders
        FillFileListb fsoSubFolder, myResults, lCount
    Next fsoSubFolder

End Sub

Private Sub fcnDumpToWorksheetb(varData As Variant, Optional mySh As Worksheet)

    Dim iSheetsInNew As Integer
    Dim sh As Worksheet, Wb As Workbook
    Dim myColumnHeaders() As String
    Dim l As Long, NoOfRows As Long

    If mySh Is Nothing Then
        'make a workbook if we didn't get a worksheet
        iSheetsInNew = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        Set Wb = Application.Workbooks.Add
        Application.SheetsInNewWorkbook = iSheetsInNew
        Set sh = Wb.Sheets(1)
    Else
        Set mySh = sh
    End If

    'since we switched the array dimensions, have to transpose
    With sh
        Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
            Application.WorksheetFunction.Transpose(varData)

        .UsedRange.Columns.AutoFit
    End With

    Set sh = Nothing
    Set Wb = Nothing

End Sub


Sub LoopThroughFiles()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim strFolder As String
    Dim strFile As String

    strFolder = "c:\My dir"
    strFile = Dir(strFolder & "\*.xls*")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Do While Len(strFile) > 0
     Set Wb = Workbooks.Open(strFolder & "\" & strFile)
     Set ws = Nothing
     On Error Resume Next
     Set ws = Wb.Sheets("Action")
     On Error GoTo 0
     If Not ws Is Nothing Then ws.SaveAs Left$(Wb.FullName, InStrRev(Wb.FullName, ".")) & "csv", FileFormat:=xlCSV
     Wb.Close False
        strFile = Dir
    Loop

     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Open in new window


Saurabh...
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Sunil KakkarAuthor Commented:
Hi Saurabh

I tested your code. It is giving Run Time error 1004. I have set reference to Microsoft Script RunTime Library. I shall check carefully late in the evening and then revert back to you.

Warm regards,

Sunil
0
Saurabh Singh TeotiaCommented:
Can you tell me which line you are getting this error??

Saurabh..
0
Sunil KakkarAuthor Commented:
Hi Saurabh,

It was my mistake as there were too many macro files  open at that time and I did not check whether specified sheet ~Action~ is present in the workbook .
I ran your program coolly after removing all the clutter. It is working fine and I am going to accept you solution.
One flexibility I desire if conveniently possible that is Instead of specifying  c:\mydir in the looping code, It can be made user chosen one .

Sub LoopThroughFiles()
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim strFolder As String
    Dim strFile As String

    strFolder = "c:\My dir"
    strFile = Dir(strFolder & "\*.xls*")

Open in new window



Thanks for your kind attention and interest.

Warm Regards,

Sunil
0
Sunil KakkarAuthor Commented:
I am highly impressed by his professional approach. His communications with the client are clear and precise. He is very cooperative.
0
Saurabh Singh TeotiaCommented:
Thanks Sunil for Kind Words..Always happy to help.. :-)

Saurabh...
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.