Copy Paste data from Files within Subfolders

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