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

**RaghavendraPrabhu** · 04-01-2018, 05:24 AM

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.

Code:

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

**DocAElstein** · 04-01-2018, 02:02 PM

Hi Raghu,

Thanks for the feedback and sharing your solution.
You have clearly worked hard to solve your problem. Great , well done!

I had a quick look through your files. It is still a bit difficult for me to understand what you are doing or wanting to do: I do not know your project so to understand would need a clear explanation from start to finish of what you are doing or wanting to do.
I see lots of codes and files but have no idea which codes and files are used for which and when. I have to work very hard to try to guess what is going on. This will be obvious to you, but without a careful explanation from you it will be impossible for anyone like me to have any idea what is going on.

But you appear to have a solution , so great.
The codes may not be the most efficient, but I think those considerations are less and less relevant for an application like yours as computers get faster and have larger memories etc..
It can be advantageous to have a long drawn out process, as this will be easier for you to follow and modify or de bug in the future. I personally prefer long drawn out codes for those reasons, but that is just my opinion, and I am just a hobby computer user and am not a professional programmer.

I expect you may be doing a lot of unnecessary sorting of data, but I cannot be sure as I do not understand what and when things are to be done.

Good luck with the project, and let us know if you need more help.
But please in future try to explain more clearly in words exactly what is to be done , and when and which data is being used for which code .. etc.. etc… You have supplied some excellent detailed Test data and files. It is a shame more explanations to them were missing: Because an explanation was missing, I still could not use them effectively to give a better solution.
You simply need to write in words the action that you take to produce the files, which codes are run and when etc… You need to understand that for someone that does not know the project details as you do, will need them to be explained carefully.

For someone with little MS Excel VBA experience you have done very well to get your working solution. Well done again.

Alan

**klimbo123** · 01-20-2019, 08:50 PM

Originally Posted by 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.

Code:

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.Lucky Patcher 9Apps VidMate

Regards

Raghu

i can't download the files why ?

**DocAElstein** · 01-20-2019, 10:16 PM

Originally Posted by klimbo123

i can't download the files why ?

Hi klimbo123
Welcome to excelfox

Please explain yourself, in much more detail, if you want any help here, at excelfox
Alan

P.s. If the probem for you is the files from here http://www.excelfox.com/forum/showth...lder#post10591
Then here they are again at a file sharing site:

WorkCondolidated 18MAR18 _____https://app.box.com/s/tythnc8zge5g1ezqnd03uzzsgufb1mnp
WorkDistributed 15MAR18 ___ https://app.box.com/s/jfpeq908wc122x18vvjub2avtmcrg8p0
WorkDistributedAndConsolidated 16MAR18 : _ https://app.box.com/s/oxih69lkebmenqi6rgshzdhonf1lbddy