Copy Paste data from Files within Subfolders

@lyla22

You can adapt from here:

Sub MiRuta()
    Dim rUta As String
    'Define here your main Path (Ruta)
    rUta = ActiveSheet.Cells(1, 4).Value
    Call Mostrar_Archivos(rUta)
End Sub

Sub Mostrar_Archivos(rUta)
 
    'Sección 1: Declare Variables and Objects
    Dim fS As Object, cArpeta As Object, aRchivo As Object, sUbcarpeta As Object
    Dim mIarchivo As String
    Set fS = CreateObject("Scripting.FileSystemObject")
     
    'Sección 2: Chek proper  rUta
    If rUta = "" Then
        Exit Sub
    ElseIf Right(rUta, 1) <> "\" Then
        rUta = rUta & "\"
    End If
     
    'Sección 3: Object Folder from rUta
    On Error GoTo ErrHandler
    Set cArpeta = fS.GetFolder(rUta)
     
    'Sección 4: Retrieve files from object Folder
    For Each aRchivo In cArpeta.Files
        mIarchivo = rUta & aRchivo.Name
        ActiveCell.Value = mIarchivo 'List all files
        ActiveCell.Offset(1, 0).Select
        '***
        'Here to call your sub MoveData()
        ' I sugest you to pass the File name variable: mIarchivo
        'MoveData (mIarchivo)
        '***
    Next
     
    'Sección 5: Search for subFolders in object Folder
    For Each sUbcarpeta In cArpeta.SubFolders
        Mostrar_Archivos (sUbcarpeta)
    Next
     
    'Sección 6: Auto-ajustar columnas y salir
    ActiveCell.EntireColumn.AutoFit
    Exit Sub
     
ErrHandler:
    ActiveCell.Value = "Ruta inexistente"
 
End Sub

If you include your MoveData code, remember to put only the process of the file, not the search.
meaning only check if the file is excel workbook, and transfer the data.
you don't need to loop again

@lyla22

You can adapt from here:

Sub MiRuta()
    Dim rUta As String
    'Define here your main Path (Ruta)
    rUta = ActiveSheet.Cells(1, 4).Value
    Call Mostrar_Archivos(rUta)
End Sub

Sub Mostrar_Archivos(rUta)
 
    'Sección 1: Declare Variables and Objects
    Dim fS As Object, cArpeta As Object, aRchivo As Object, sUbcarpeta As Object
    Dim mIarchivo As String
    Set fS = CreateObject("Scripting.FileSystemObject")
     
    'Sección 2: Chek proper  rUta
    If rUta = "" Then
        Exit Sub
    ElseIf Right(rUta, 1) <> "\" Then
        rUta = rUta & "\"
    End If
     
    'Sección 3: Object Folder from rUta
    On Error GoTo ErrHandler
    Set cArpeta = fS.GetFolder(rUta)
     
    'Sección 4: Retrieve files from object Folder
    For Each aRchivo In cArpeta.Files
        mIarchivo = rUta & aRchivo.Name
        ActiveCell.Value = mIarchivo 'List all files
        ActiveCell.Offset(1, 0).Select
        '***
        'Here to call your sub MoveData()
        ' I sugest you to pass the File name variable: mIarchivo
        'MoveData (mIarchivo)
        '***
    Next
     
    'Sección 5: Search for subFolders in object Folder
    For Each sUbcarpeta In cArpeta.SubFolders
        Mostrar_Archivos (sUbcarpeta)
    Next
     
    'Sección 6: Auto-ajustar columnas y salir
    ActiveCell.EntireColumn.AutoFit
    Exit Sub
     
ErrHandler:
    ActiveCell.Value = "Ruta inexistente"
 
End Sub

If you include your MoveData code, remember to put only the process of the file, not the search.
meaning only check if the file is excel workbook, and transfer the data.
you don't need to loop again

I adapted this code from ExelTotal.com
sorry it's in spanish.... but is easy to understand

Vicho

Hi lyla22

I'm guessing about your work, as I didn't see your data
I hope it goes OK for you

Please give it a try over some sample data, until you are sure it is OK
sorry for the double posting before.

Option Explicit
Sub MiRuta()
    Dim rUta As String
    'Define here your main Path(rUta)
    rUta = Sheets("Instructions").Range("B1")
    Call Mostrar_Archivos(rUta)
End Sub

Sub Mostrar_Archivos(rUta)

    Dim fS As Object, cArpeta As Object, aRchivo As Object, sUbcarpeta As Object
    Dim mIarchivo As String
    Set fS = CreateObject("Scripting.FileSystemObject")
    If rUta = "" Then
        Exit Sub
    ElseIf Right(rUta, 1) <> "\" Then
        rUta = rUta & "\"
    End If
    On Error GoTo ErrHandler
    Set cArpeta = fS.GetFolder(rUta)
    For Each aRchivo In cArpeta.Files
        Call MoveData(aRchivo)
    Next
    For Each sUbcarpeta In cArpeta.SubFolders
        Mostrar_Archivos (sUbcarpeta)
    Next
    Call Arrenge
    Exit Sub
ErrHandler:
    MsgBox "Ruta inexistente"
 
End Sub


Sub MoveData(MyFilename)
    Application.EnableCancelKey = xlDisabled
    Dim Ext As String
    Dim wb As Workbook
    Dim rng As Range
    Dim rngCell As Range
    Dim rngTarget As Range
    Dim calcmode As Long
    Dim lCount As Long
    Dim lX As Long

    With Application
        calcmode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .StatusBar = "Importing data..."
    End With
 
'    With ActiveSheet
'        If MsgBox("WARNING!" & vbCrLf & "If you proceed, all data in this worksheet will be overwritten." & vbCrLf & _
'        "Do you wish to continue?", vbYesNo) = vbYes Then
'            On Error Resume Next
                ActiveSheet.Range("A2").Select
                ActiveSheet.ShowAllData
                ActiveSheet.UsedRange.Offset(1).EntireRow.ClearContents
'            ElseIf MsgBox("Import cancelled.", vbOKOnly) = vbOK Then
 
'                With Application
'                .ScreenUpdating = True
'                .EnableEvents = True
'                .Calculation = calcmode
'                End With
'            Exit Sub
'        End If
'    End With

Ext = ".xls"

If Right(MyFilename, 4) = Ext Then
    Set rngTarget = Worksheets("Master").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
        Set wb = Workbooks.Open(MyFilename)
        Set rng = wb.Sheets("Sheet1").Range("c4,c5,c15,c16,c17,c25,c26,c27,d15,d16,d17,d25,d26,d27,e15,e16,e17,e25,e26,e27")
            For Each rngCell In rng
            lX = lX + 1
            rngTarget.Offset(0, lX - 1).Value = rngCell.Value
            Next
        Workbooks(MyFilename).Close True
        lX = 0

            With Application
                .ScreenUpdating = True
                .EnableEvents = True
                .Calculation = calcmode
                .StatusBar = False
            End With
End If
End Sub

Sub Arrenge()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Dim LR As Long
    
LR = ActiveSheet.UsedRange.Rows.Count

Range("V2").Select
ActiveCell.FormulaR1C1 = "=RC[-20]"
Range("V3").Select
ActiveCell.FormulaR1C1 = "=IF(R[-1]C[-21]=RC[-21],"""",RC[-21])"
Range("V3").AutoFill Destination:=Range("V3:V" & LR)
Range("W2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-21]="""",22,RC[-21])"
Range("W2").AutoFill Destination:=Range("W2:W" & LR)
ActiveSheet.Range("U2").Value = Sheets("Instructions").Range("B3").Value
Range("U2").AutoFill Destination:=Range("U2:U" & LR)
Range("A2").CurrentRegion.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
ActiveSheet.ListObjects("chtData").Resize Range("$A$1:$W$1000")
ActiveSheet.ListObjects("chtData").Range.AutoFilter Field:=1, Criteria1:="<>"
Range("C:E").Interior.ColorIndex = 15
Range("I:K").Interior.ColorIndex = 15
Range("O:Q").Interior.ColorIndex = 15
Columns("C:C").Select
Selection.NumberFormat = "General"
Columns("V:V").Select
Selection.NumberFormat = "dd/mm/yyyy"
Columns("W:W").Select
Selection.NumberFormat = "[$-F400]h:mm:ss am/pm"
Range("A2").Select
MsgBox "The import is complete, Click OK to continue"

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

Sheets("chtShiftData").Select
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
ActiveSheet.Range("$A$1:$D$1000").AutoFilter Field:=1, Criteria1:="<>"
Sheets("Master").Activate

End Sub

OK lyla22
Let's go step by step.

Fill your own path in cell B1,
In the attached book I've placed two buttons on sheet Parameters.
first click TEST1
it should show you ALL files in your path, including subfolders.

If this test is OK, then clean the data showed and click TEST2
now it should show you all EXCEL files: xls, xlsx, xlsm... etc.

I'm waiting for your comments.

In your original post, you placed as the first action:

                ActiveSheet.Range("A2").Select
                ActiveSheet.ShowAllData
                ActiveSheet.UsedRange.Offset(1).EntireRow.ClearContents

I guess that it is acting over your "Master" sheet, in order to clean all the data from a previous run.
But using the "UsedRange" property to find the last row, is not a good idea, while you have a named range "chtData" defined to row 1000
so the code is writing the imported values in row 1001 and so .

Just to test please eliminate the named range to see if the code can perform what you need.
click on TEST

Sorry
the book was not attached

That means we are having problems to "Close and Save" the opened book.
Could you please post the book with out the named range (I can not delete because it is password protected), and one sample book from where you import data.
How many books are involved in the process (Aprox.) ...?, Are all of them exactly the same estructure??
From your code, there is no change on the data source book...do you realy need to Save it when closing?
On your last TEST, that single row of data from the first book, was correct? Complete? On the first row under the title?

Good news @lyla22
Let me play around during weekend
I'll come back on monday.

Vicho

Hi @lyla22

I think I found the bug.
please try this book with your own path

I'm pleased to be able to help.

First I suggest you to read about the "moduldes" in VBA ( the web is plenty of information).
This is a good place to start reading:

HTML Code: 

The codes we are writing here should go into regular modules, not in a sheet module.

Second, whenever you write a code, and it gets long enought to be difficult to follow, then it's time to brake it into smaller pieces.

Third, trying to clear, add, delete data or rows/columns in a filtered range, can produce unexpected results, so it's a good practice to unfilter, do the job, and filter again.

With this in mind, let's talk about the codes:
Sub MiRuta3() takes the path (ruta in spanish) from sheet Parameters, to search the files in that folder and sub-folders.
then unfilter sheet Master, and clean all the previous data.
then it calls the sub Mostrar_Archivos3(rUta), passing the variable ruta; at the end of this sub, Master sheet will be filled with all the data imported from all the files in ruta and its subfolders.
then the new table is auto-filtered again, letting it ready to be explored.

Call Mostrar_Archivos3(rUta) is a generic routine that you can use whenever you need to search files inside a folder (which path is ruta), and its subfolders, using the FileSystemObject.. this is a recursive sub as you can see, it calls itself passing this time the subfolder path....
here we used an IF statement to filter only .xls files.
So every time we find a file we proceed with an action, in our case the action is defined in another sub: MoveData3(aRchivo), to wich we are passing the path to that specific workbook (archivo). This sub will produce one new line at the bottom of the Mastersheet, for each file found.
After all the files are processed, we are calling a final sub Arrenge (by now it is commented with an apostrophe). this sub will be on charge to do all the calculations on the data created until now.

In the sheet2 Master Module I left the arrenge code....(Note that this is not the place where it has to be, I used it as a momentary storage, you shoul cut it from here and paste in the regular Module 2). So you can uncomment the call Arrenge line. Do this, and try to see how it goes.

I can guess that you recorded a macro from your actions.....
Do you really need to write formulas? or you just want to have the results the formula calculations.?