Copy data from Unique files into Masterfile all the files in the same folder.

[RaghavendraPrabhu]

Hi Doc Elstein,

I have sorted out the problem. It is a bit convoluted, but it is working. Please have a look at the code below.

Option Explicit
Sub BringInAllCompletedData()
    Call SortAllFiles
    Call LoopThroughDirectory
    Call UpdateDateInSheet1ColK
    Call UpdateOriginalData
    Call ClearSheet1
End Sub

'https://www.mrexcel.com/forum/excel-questions/471802-vba-open-file-run-code-close-save-open-next-file.html
Sub SortAllFiles()
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook
    
    Application.DisplayAlerts = False
    
    folderPath = ActiveWorkbook.Path & "\" 'change to suit
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
        filename = Dir(folderPath & "*.xlsx")
            Do While filename <> ""
                Application.ScreenUpdating = False
                Set wb = Workbooks.Open(folderPath & filename)
                'Call a subroutine here to operate on the just-opened workbook
                If filename = "zmaster.xlsm" Then
                    Exit Sub
                Else
                    Call SortSheet1InAllFiles
                End If
                filename = Dir
            Loop
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
End Sub

Sub SortSheet1InAllFiles()
Dim MyFile As String
Dim eRow As Long
Dim RowsConsolidated As Long
Dim LastRow As Long
Dim i As Long

    eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K2:K" & eRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:N" & eRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Save
    Range("A1").Select
    ActiveWorkbook.Close
    
End Sub

'http://www.exceltrainingvideos.com/transfer-data-multiple-workbooks-master-workbook-automatically/
 
Sub LoopThroughDirectory()
Dim MyFile As String
Dim eRow As Long
Dim LRL As Long
Dim LRK As Long
Dim i As Long
 
Dim FilePath As String
FilePath = ActiveWorkbook.Path & "\"
        
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Sheets("Sheet1").Activate
MyFile = Dir(FilePath)
    Do While Len(MyFile) > 0
        If MyFile = "zmaster.xlsm" Then
            Exit Sub
        End If
       
        Workbooks.Open (FilePath & MyFile)
        LRK = Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).Row 'Column L
        LRL = Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).Row 'Column K
        
        For i = LRL To LRK
                Range("A" & LRL & " : " & "K" & LRK).Copy
        Next
        ActiveWorkbook.Close
   
        eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(eRow, 1), Cells(eRow, 11))

        
        If MyFile = "zmaster.xlsm" Then
            Exit Sub
        End If
       
        Workbooks.Open (FilePath & MyFile)
        For i = LRL To LRK - 1
            If Range("L" & i).Value = "" Then
                Range("L" & i).Value = Date
                Columns("L:L").NumberFormat = "[$-C09]dd-mmm-yy;@"
            End If
        Next
        Range("A1").Select
        ActiveWorkbook.Save
        ActiveWorkbook.Close
       
        MyFile = Dir
        ActiveWorkbook.Save
    Loop
        
    Columns("A:D").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A" & eRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:D" & eRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
              
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
End Sub

Sub UpdateDateInSheet1ColK()
Dim eRow As Long
Dim i As Long

    Sheets("Sheet1").Activate
    eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For i = 2 To eRow
            If Range("K" & i) <> "" Then
                Range("L" & i).Value = Format(Date, "dd/mmm/yyyy")
            End If
        Next
End Sub

'https://www.youtube.com/watch?v=AzhQ5KiNybk
Sub UpdateOriginalData()
Dim i As Integer
Dim j As Integer
Dim LastRow1 As Integer
Dim LastRow2 As Integer
Dim SNo As Double

LastRow1 = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
LastRow2 = Sheets("OriginalData").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow1
    SNo = Sheets("Sheet1").Cells(i, "A").Value
        Sheets("OriginalData").Activate
        For j = 2 To LastRow2
            If Sheets("OriginalData").Cells(j, "A").Value = SNo Then
                    Sheets("Sheet1").Activate
                    Sheets("Sheet1").Range(Cells(i, "G"), Cells(i, "L")).Copy
                    Sheets("OriginalData").Activate
                    Sheets("OriginalData").Range(Cells(j, "G"), Cells(j, "L")).Select
                    ActiveSheet.Paste
            End If
        Next j
        Application.CutCopyMode = False
Next i
    Sheets("OriginalData").Activate
    Cells.Select
    ActiveWorkbook.Save
    Selection.Columns.AutoFit
    Range("A1").Select

End Sub

Sub ClearSheet1()
Dim eRow As Long

    Sheets("Sheet1").Activate
    eRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    Range("A2:O" & eRow).Select
    Selection.ClearContents
    Selection.Columns.AutoFit
    Range("A1").Select
    ActiveWorkbook.Save
End Sub

Thank you for all your suggestions and input. What I have done is a long drawn process. Maybe it can be written into one macro.

I will consider this as solved.

Thank you for all your help, time and patience.

Regards

Raghu