Hi,

I have a macro that runs over a defined directory, creates a new summary workbook, and then copies selected data from all the excel files present (in the defined directory) into that summary workbook, it then saves the summary workbook into a defined location and closes. I am obliged to change the directory name each time I have multiple folders for data merging, and sometimes over 30 directories.

I want this macro to loop automatically over several directories contained inside one root directory and perform the same operation detailed above. How can it be possible? I used the "scripting folder" method but it returned error when I ran the code...never got it worked!

Secondly, I want this macro to save the summary workbook with its folder name, the directory from which data is merged.

My code is here, please take a look and propose me a solution:

Sub MergeSitu()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceCcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange1 As Range, destrange1 As Range
    Dim sourceRange2 As Range, destrange2 As Range
    Dim sourceRange3 As Range, destrange3 As Range
    Dim Rnum As Long, CalcMode As Long
    Dim Cnum As Long
    Dim listwb As Workbook
    
     ' Change this to the path\folder location of the files.
    MyPath = "D:\data\19h\13 feb\"

    ' Add a slash at the end of path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xlsx*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    ' Fill in the myFiles array with the list of Excel files in
    ' the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Change the application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Add a new workbook with one sheet.
    With Application

    '--> Set contractor list file
    Set listwb = .Workbooks.Open _
    ("D:\data\DataAssemble.xlsx")
    End With
    Set BaseWks = listwb.Sheets(1)
    Cnum = 1
    ActiveWorkbook.Sheets(1).Select
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "Prod"
    
    Dim mMonth As Range
 For Each mMonth In Sheets(1).Range("P1")
    ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.count)
     ActiveSheet.Name = mMonth
Next
Set BaseWks = listwb.Sheets(7)
Cnum = 1

    ' Loop through all of the files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                Set sourceRange1 = mybook.Worksheets(1).Range("A1:B1420")

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange1 = Nothing
        
                Else
                    ' If the source range uses all of the rows
                    ' then skip this file.
                    If sourceRange1.Rows.count >= BaseWks.Rows.count Then
                        Set sourceRange1 = Nothing
                        
                    End If
                End If
        
                On Error GoTo 0

                If Not sourceRange1 Is Nothing Then

                    SourceCcount = sourceRange1.Columns.count

                    If Cnum + SourceCcount >= BaseWks.Columns.count Then
                        MsgBox "There are not enough columns in the sheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in the first row.
                        With sourceRange1
                            BaseWks.Cells(1, Cnum). _
                                    Resize(, .Columns.count).Value = MyFiles(FNum)
                        End With
    

                        ' Set the destination range.
                        Set destrange1 = BaseWks.Cells(1, Cnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange1
                            Set destrange1 = destrange1. _
                                            Resize(.Rows.count, .Columns.count)
                        End With
                        
                        destrange1.Value = sourceRange1.Value

                        Cnum = Cnum + SourceCcount
                    End If
                End If
            mybook.Close savechanges:=False
            End If
BaseWks.Columns.AutoFit
        Next FNum

    End If

    listwb.Activate
    ActiveWorkbook.SaveAs Filename:="D:\data\Merged\19h\Data_ " & (FolderName) & ".xlsx", Password:="", _
    WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
 ActiveWorkbook.Close

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Thanks alot in advance!

Sanjeev