Transfer Data Multiple Workbooks Master Workbook Automatically

We can transfer data from multiple workbooks into a master Excel workbook automatically using VBA.
We have, let’s say, four Excel workbooks with the names: supplier-a.xlsx, supplier-b.xlsx, supplier-c.xlsx and zmaster.xlsm in the folder ‘C:Work\Excel_Tutorial’.
Screen shots of the data containing files is given below:

Data of Supplier-a
Data of Supplier-a
Data of Supplier-b
Data of Supplier-b
supplier-c-data
supplier-c-data
zmaster-data
zmaster-data

The complete macro code is given below:

Advanced Modelling in Finance
Advanced Modelling in Finance

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = “C:\Work\Excel_Tutorial\”
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = “zmaster.xlsm” Then
Exit Sub
End If

Workbooks.Open (Filepath & MyFile)
Range(“A2:D2”).Copy
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, 4))

MyFile = Dir
Loop
End Sub

Note: Many thanks to Darren Elliot, a proactive website visitor,  who contributed to a major correction in the above code.

Watch the Excel training video to see how the complete process of moving multiple files from one folder to another is implemented:


Further reading:
Range.Cells Property (Excel)

Advanced modelling in finance using Excel and VBA

63 thoughts on “Transfer Data Multiple Workbooks Master Workbook Automatically”

  1. Hi, I have tried your VBA but I got an error “Runtime error 424” Object Required :
    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    Please advise, thanks,

    1. what is the vb code if suppliers files have multiple sheets and we have to transfer data from sheet no 5 of each suppliers file into master file

        1. Dear Sir,

          I have created a Master file as below link. I am also sending the data source files. What I am facing is if any of the source file filtered during work, the macro can import only the visible rows data to master file.

          https://www.dropbox.com/sh/s3dnjvs44eood36/AAAkm8COeNq5v6_0NnP3Lru4a?dl=0

          1) I need all rows data from the source files to be exported to master file once I will press the “Update Data” command button in master file.

          2) Also I have added two buttons, “Clear Data” button for clearing the old data from Master file and “Update Data” button for update new data in Master file. Here is it possible to do two above jobs (Clearing old data and update with new data) with only one Command button “Update Data”.

          I am eagerly waiting if you help me.

        2. hi, how to copy data in horizontally(column) based on file name(date) to master xls date column.

          All slave file having information on E5 to E9, file name eg. “Report_S3_UP W_352315062479619_15Jun19_220002.1_template_22042015” one file for a day. i want to copy this 5 row information of per file to per date column in the master sheet

      1. ActiveWorkbook.Paste Destination:=Workbooks(“C:\Users\AK5040872\Desktop\Automation\02142018\EXECUTIONSHEETday1.xlsx”).Worksheet(“BASELINE”).Range(Cells(erow, 1), Cells(erow, 201)) is this sytax correct

  2. Dear sir,

    i need your help for set dir default path. if i move file to different location .it should be automatically set directory path .

    MYFile =dir(c:\supplier\test)

  3. Dear Sir

    I have a master file with new pay package like basic salary, allowances etc to all employees as one worksheet in the file. I have 450+ individual employee time sheet files.

    I wish to transfer basic data like wages in to all files from the master files. the timesheets are all in the similar format.

    can you help me with a vba code so that i can save lot of time and this is usual work for me every year. here Employee code remains unique in master workbook and also time sheets workbook files. Sir can you please help me to solve this problem

    Many thanks in advance
    Val Cardoza

    1. Thank you so much! I've spent the last few hours trying to find this data for download, which isn't mentioned on the CPRM page. Apologies for commenting in English, it's the only language I know.

    2. Kjempe flott pute du har laget deg moa, og det broderiet var kjempe flott…..Var selv pÃ¥ loppis i dag og fant masse flott, blant annet en kjempe fin blomstrete lampeskjerm, som med en gang jeg sÃ¥ den sÃ¥ tenkte jeg pÃ¥ deg…..ha en fin søndag vidre snuppaklemmer i fleng

  4. I am trying to use this code but it is not showing any result. Could you please help me in this thing.
    It is not showing any errors also.

  5. I am trying to use this code but it is not showing any result. Could you please help me in this thing.
    It is not showing any errors also.
    This is the code which i tried

    Sub copy()

    Dim myfile As String
    Dim erow
    Dim Filepath As String

    Filepath = “G:\VBA\”

    myfile = Dir(Filepath)

    Do While Len(myfile) > 0
    If myfile = “Master.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & myfile)
    Range(“A2:C2”).copy
    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, 3))

    myfile = Dir

    Loop

    End Sub

    1. Hi Dharmateja Try this….
      Sub LoopThroughDirectory()
      Dim MyFile As String
      Dim eRow As Long
      Dim fRowTBC As Long
      Dim LastRow As Long
      Dim i As Long

      Dim FilePath As String
      FilePath = ActiveWorkbook.Path & “\”
      MyFile = Dir(FilePath)
      Do While Len(MyFile) > 0
      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1″).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC

      If (eRow – fRowTBC) = 0 Then
      MsgBox ” There is no data to extract from ” & MyFile
      End If

      For i = 2 To eRow
      If Range(“E” & i).Value = “” Then
      Range(“A” & fRowTBC & ” : ” & “D” & eRow).Copy
      End If
      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, 4))

      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC
      For i = 2 To eRow – 1
      If Range(“E” & i).Value = “” Then
      Range(“E” & i).Value = Date
      Columns(“E:E”).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:A31”) _
      , 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
      MsgBox “Extracted all available Data!”
      End Sub

  6. Hey there,

    Like the person above, I’m not getting any results (or any errors). The only thing I modified is the directory location and the cell range I want to paste (A3:M3). Here’s the code:

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “C:\Users\iaslab\Desktop\HBD_Rescored_141114 – Copy”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “zHBD_Compiled.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range(“A3:M3”).Copy
    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, 4))

    MyFile = Dir
    Loop
    End Sub

    1. Hi F

      Try this…

      Sub LoopThroughDirectory()
      Dim MyFile As String
      Dim eRow As Long
      Dim fRowTBC As Long
      Dim LastRow As Long
      Dim i As Long

      Dim FilePath As String
      FilePath = ActiveWorkbook.Path & “\”
      MyFile = Dir(FilePath)
      Do While Len(MyFile) > 0
      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1″).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC

      If (eRow – fRowTBC) = 0 Then
      MsgBox ” There is no data to extract from ” & MyFile
      End If

      For i = 2 To eRow
      If Range(“E” & i).Value = “” Then
      Range(“A” & fRowTBC & ” : ” & “D” & eRow).Copy
      End If
      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, 4))

      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC
      For i = 2 To eRow – 1
      If Range(“E” & i).Value = “” Then
      Range(“E” & i).Value = Date
      Columns(“E:E”).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:A31”) _
      , 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
      MsgBox “Extracted all available Data!”
      End Sub

    1. Hi Nandu

      Try this..

      Sub LoopThroughDirectory()
      Dim MyFile As String
      Dim eRow As Long
      Dim fRowTBC As Long
      Dim LastRow As Long
      Dim i As Long

      Dim FilePath As String
      FilePath = ActiveWorkbook.Path & “\”
      MyFile = Dir(FilePath)
      Do While Len(MyFile) > 0
      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1″).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC

      If (eRow – fRowTBC) = 0 Then
      MsgBox ” There is no data to extract from ” & MyFile
      End If

      For i = 2 To eRow
      If Range(“E” & i).Value = “” Then
      Range(“A” & fRowTBC & ” : ” & “D” & eRow).Copy
      End If
      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, 4))

      If MyFile = “zmaster.xlsm” Then
      Exit Sub
      End If

      Workbooks.Open (FilePath & MyFile)
      eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
      fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
      Debug.Print eRow
      Debug.Print fRowTBC
      For i = 2 To eRow – 1
      If Range(“E” & i).Value = “” Then
      Range(“E” & i).Value = Date
      Columns(“E:E”).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:A31”) _
      , 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
      MsgBox “Extracted all available Data!”
      End Sub

  7. Hi DInesh,

    How can I add data from different workbooks into a master workbook having same headers and row labels?

    e.g. I have Distributor plan workbook containing 6 different sheets, which is sent to be filled by around 150 Distributors. I am getting replies from them. Now i want the sum of all the replies in a master sheet, which is designed same as the file sent to the distributors.
    So how can I get that done?

    Please help.

    Thanks in advance…!!

  8. Sir,

    in the above example, the entire row containing ‘Car’ is copied to another sheet. a slight addition in requirement, I would like to refer to the cell containing ‘Car’ in sheet 1 and copy the entire contents in that row to sheet 2 after the cell that contains ‘Car’. i.e. data of matching cells to be copied to another sheet against that cell.

    regds,

    Anaand Kulkarni

  9. Hello sir,

    I have a question adapting your code my my situation. I am trying to compile the data from multiple files into one, as you did. The sheet is “Admissions” and it is a large mulitple row/column dataset I am copying. Everytime I run the code it gives me a runtime error 1004 applicaiton-defined or object defined error and leads me to my activesheet.paste command for debugging. I can not see what the error is an hope you can point it out to me.

    Many Thanks.

    Brian

    Sub AdmissionTransfer()
    Dim MyFile As String
    Dim erow
    Dim endrow
    Dim FilePath As String
    Dim AdmDate As String
    Dim Admits As Range

    FilePath = “C:\Users\brian.murray\Downloads\”
    MyFile = Dir(FilePath)

    Do While Len(MyFile) > 0

    If MyFile = “ztest.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    Sheets(“Admissions”).Select
    AdmDate = Cells(1, 1).Value
    endrow = Cells(Rows.Count, 4).End(xlUp).Offset(0, 0).Row
    Range(Cells(3, 4), Cells(endrow, 13)).Copy

    ActiveWorkbook.Close

    ActiveSheet.Paste Destination:=Worksheets(“Admissions”).Range(Cells(erow, 2), Cells(erow + endrow – 3, 11))
    Worksheets(“Admissions”).Range(“A” & erow).Value = AdmDate
    Worksheets(“Admissions”).Range(“A” & erow, “A” & erow + endrow – 3).FillDown

    MyFile = Dir

    Loop

    End Sub

  10. I copied the same code but it is giving me error- Run Time Error “424”
    If MyFile = “zmaster.xlsx” then

    Donr know what is wrong?

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “D:\Users\hm10345\Desktop\supplier-master\”

    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsx” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range(“A2:D2”).Copy
    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, 4))

    MyFile = Dir
    Loop
    End Sub

  11. Sir,

    I’m getting an error for the below code:

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String

    Filepath = “C:\Users\Winston\Documents\Family Budget\Fiscal Year 11-12\”

    MyFile = Dir(Filepath)

    Do While Len(MyFile) > 0
    If MyFile = “YearlyExpense.Xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Worksheets(“Categorized”).Range(“B32:V32”).Copy
    ActiveWorkbook.Close

    erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(“sheet2”).Range(Cells(erow, 1), Cells(erow, 22))

    MyFile = Dir
    Loop
    End Sub

    The error is Runtime error 1004 “FileName” could not be found error

    It is displaying the file it found “FileName”. Kindly, check my complete requirement under the following link:

    http://stackoverflow.com/questions/29860343/

    Kindly, help!

  12. Sir,
    I created three supplier files as like you and one master file and save them in Supplier-master folder. and then create the code same as your’s but when i try to run this code its give me the error “424”.
    I tried to much to solve this problem but i can not do this and I need your valuable support.

  13. I copies the above code :
    but i need to copy range of data i.e. ranged cells need to copy at one location and followed by emply line next file data has to copy.

    Kindly help me in this regard.

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “C:\Work\Excel_Tutorial\”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range(“A2:D2”).Copy
    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, 4))

    MyFile = Dir
    Loop
    End Sub

  14. I have created 3 supilers which has different-2 range like (Suplier -1 (A2:D50) next suplier range is (A2:D10) and (A2:D60), so kindly suggest me how I can manipulate my range so that i can get all information. Please help me as soon as possible

    Sub LoopThroughDirectory2()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “D:\Camera\”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “mastershert.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range(“A2:D10”).Copy
    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, 4))

    MyFile = Dir
    Loop
    End Sub

  15. Hello,

    I Tried this but still I am facing problem, so please help me as soon as possible.

    Sub LoopThroughDirectory2()
    Dim MyFile As String
    Dim erow
    Dim lastrow As Long
    Dim Filepath As String
    Filepath = “D:\Camera\”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “mastershert.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    lastrow = Sheets(“sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
    Range(“A” & lastrow).Copy

    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, 4))

    MyFile = Dir
    Loop
    End Sub

  16. sir, I am struck up in peculiar problem, we have an excel sheet which has work order and counter and process name and process stage, everyday we have 100’s of workorder and i am manually looking at the same and updating, i want this to be automated,, can you please give me your email id to share data

  17. Dear Sir,

    I hope you are doing well.

    I have a query with, I have multiple worksheets more than 15 and i want to copy data from each worksheet, “sheet1” and paste that data in Consolidate data file in “Sheet1” that format in excel 2003.

    Can it is possible, i was use all suggested code which you are recommend in your website.

    Regards,
    Neeraj Jha

  18. Hi there,
    Thank you for your help… I have tried to adapt the code to my needs, but unfortunately it is not working

    I want to copy the cells from D8:P8 that are located in the SUMMARY worksheet in each workbook, and paste in to my “LME Master Log Summary” (in the Master Summary worksheet)

    Please help

    ———————————-
    Sub LMEMaster()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = ThisWorkbook.Path
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “LME Master Log Summary.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Worksheets(“SUMMARY”).Activate
    Range(“D8:P8”).Copy
    ActiveWorkbook.Close

    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(“Master Summary”).Range(Cells(erow, 1), Cells(erow, 4))

    MyFile = Dir
    Loop
    End Sub

    ————————————————

  19. The current code is excellent but can you please show how and where do I add in additional row selection criteria to this existing code? My each of my sheets have multiple years so I want to make a master sheet by Year which for me Year is the column header in column 4 of each of the sheets. For instance if I only want to make a master sheet for “2015” where would I add this in and what additional dim or IF criteria do I need to add?
    Thanks

    Thanks

  20. Hi…
    1. I wanted to copy whole data from 2 or 3 excel files which will contain a single sheet inside and paste them (over writing the previous contents except the column header) in master excel. and delete those source files.
    2. and this should repeat once in every day at a given time, automatically using macro.
    can any one help me on this please..

  21. I need exactly this for my forecast updates where I get data from various sales engineers.( North, South East and west) I don’t want to copy paste manually from individual files to the master file where new forecast are added every week
    Once we receive the order from the forecast its change to closed and moved to another sheet ( I am using a command button for moving and is working fine)

    I tried using your code which if works will help save lot of my time. but it is not reading after first exit sub. Even I tried giving similar file name and path. Not showing any error

    .

  22. Hi sir,
    actually tried the above same code..but at the run time it displaying an error like “Run time error, object required”…will you please point out please…
    the following code i tried….

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow

    MyFile = Dir(“C:\Users\vinod.ashok.bhagat\Desktop\testing\”)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (MyFile)
    Range(“A3;D3”).Copy
    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, 4))

    MyFile = Dir

    Loop
    End Sub

  23. Dear Sir,

    I tried the same code as above mentioned by you in video tutorial and save the folder in Desktop. when I run it no error coming however no data appearing on Master sheet as well.
    Could you please advise what could be done. I am using Excel 2010. I am new to this VBA thing.

  24. Hi , Is it possible to include the file names of the source files into the destination worksheet ? Since I have been importing multiple excel sheets i need an identifier in the destination worksheet. I am clueless about vba /macro/excel programming. Pls help me

  25. Hi Dinesh,

    Thanks. Your code is working fine. Please modify so that it can copy multiple records and copy the record only once. In column E it should Indicate Copied and ignore if the code is run again.

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim eRow As Long
    Dim LastRow As Long

    Dim FilePath As String
    FilePath = ActiveWorkbook.Path & “\”
    MyFile = Dir(FilePath)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    ‘If Range(“E2”).Value = “” Then
    Range(“A2:E20”).Copy
    ‘End If
    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, 5))

    MyFile = Dir
    ActiveWorkbook.Save
    Loop
    End Sub

    Regards

    Raghu

  26. Hi Dinesh,

    Hi have been able to sort it out due to your training videos..

    [code]

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim eRow As Long
    Dim fRowTBC As Long
    Dim LastRow As Long
    Dim i As Long

    Dim FilePath As String
    FilePath = ActiveWorkbook.Path & “\”
    MyFile = Dir(FilePath)
    Do While Len(MyFile) > 0
    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
    Debug.Print eRow
    Debug.Print fRowTBC
    For i = 2 To eRow
    If Range(“E” & i).Value = “” Then
    Range(“A” & fRowTBC & ” : ” & “D” & eRow).Copy
    End If
    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, 4))

    If MyFile = “zmaster.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (FilePath & MyFile)
    eRow = Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    fRowTBC = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
    Debug.Print eRow
    Debug.Print fRowTBC
    For i = 2 To eRow – 1
    If Range(“E” & i).Value = “” Then
    Range(“E” & i).Value = Date
    Columns(“E:E”).NumberFormat = “[$-C09]dd-mmm-yy;@”
    End If
    Next
    Range(“A1”).Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close

    MyFile = Dir
    ActiveWorkbook.Save
    Loop
    End Sub

    [/code]

  27. Name: Devbrat Vharatdaj
    sir thank a lot for your video.
    i have a problem related to copy past function as follows:
    on daily basis i copy and past data from 300 to 400 excel sheets form same excel work book. from time to time new excel sheets are added as well as deleted.

    Hence forth i would like to run copy past of data one below another with the help of ends copy loop function.

    i am ready to share my file .

    there provide code to do it.

    do the need full.

  28. Hi,
    I have used this code and it works perfectly and I am so thankful! Is there any way I can update the syntax by making excel copy and paste my values in exactly the same format? It gets confused with the decimal numbers, I have tried “pasteSpecial” but it’s not working. I have looked on other websites but it seems I need to change the whole code just to make excel doing it and I am definitely lost.
    Thank you!!

  29. Dinesh Sir Please help in this:
    “copy Data From Multiple Workbooks into master Workbook looping Files Automatically “the above mentioned Code is not working.

  30. Hi,

    Can any1 post the VBA for transfering data from 1 workbook(Having multiple sheets) where each sheet becomes a separate excel workbook?

  31. Dear All,

    all are wrong… there are simply lake of common sense …
    How can you first give command copy , then close that file and then try to paste that data in another workbook or sheets? naturally both file must be opened before pasting …

    please commenting on workbook.close & try

    Regards,
    Chirag Raval

  32. Good Morning
    I copied your code and altered as follows but getting an error when trying to Active Sheet paste:

    Sub LoopThroughDirectory3()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “E:\Nampak Questionnaires\”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “Macros Consolidated.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)

    Range(“A2:HG22”).Copy
    ActiveWorkbook.Close

    erow = Sheet7.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(“Main Data”).Range(Cells(erow, 1), Cells(erow, 215))

    MyFile = Dir
    Loop
    End Sub

    Also the information I wish to copy from the workbooks is not on Sheet1 of the Workbooks but on a Sheet called “Consolidation.
    I also do not wish to Paste into Sheet 1 of my Master Workbook but into a Sheet Named “Master Data.

    Please help me in altering with the code.
    Thank you.

  33. Could you please assist.
    It is only copying from one workbook in the folder and pasting into Cell A2 when the first blank row is Row 3.
    Sub LoopThroughDirectory5()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = “E:\Nampak New\Questionnaire\”
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = “ZMacros Consolidated.xlsm” Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range(“A3:HG22”).Copy
    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, 215))

    MyFile = Dir
    Loop
    End Sub

    Also if I wanted to:
    Copy from Sheet 2 and Paste in Sheet 2
    Copy from Sheet 3 and Past in Sheet 3
    How would I change the code?

    Thank you for your help.

  34. Hi All,

    I have a master file with the following headings

    S No
    Item
    Price
    Qty
    Total
    Distributed
    Task1
    Task2
    Task3
    Task4
    Completed
    Consolidated
    Comments
    Team Member

    The Team leader inputs the data in first 3 columns and selects the name of the team member to be given the task for column 14.

    He then runs the macro ExportByName and new workbooks are created if they already exist then add to the end of the file.

    The team members do the tasks and fill in columns Task1, Task2, Task3, Task4 and then date completed.

    When the team leader runs the following macros

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

    All the work completed is consolidated.

    [code]

    Sub ExportByName()
    Dim unique(1000) As String
    Dim wb(1000) As Workbook
    Dim ws As Worksheet
    Dim x As Long
    Dim y As Long
    Dim ct As Long
    Dim uCol As Long

    On Error GoTo ErrHandler

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    ‘Your main worksheet info.
    Set ws = ActiveWorkbook.Sheets(“OriginalData”)

    Let uCol = 14 ‘Column O

    Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End

    (xlUp).Row

    Let ws.Range(“F” & Strt & “:F” & Stp & “”).Value = Format(Date, “dd/mmm/yyyy”) ‘ adding the dates to the new rows

    Let ws.Range(“A” & Strt & “:A” & Stp & “”).Value = Application.Evaluate(“=row(” & Strt & “:” & Stp & “)-1”) ‘ adding the S.no. to

    the new rows

    ct = 0

    For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
    unique(ct) = ActiveSheet.Cells(x, uCol).Text
    ct = ct + 1
    End If
    Next x

    For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row – 1
    If unique(x) “” Then
    If Dir(ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, vbNormal) = “” Then ‘If unique file does not exist

    Workbooks.Add: Set wb(x) = ActiveWorkbook
    ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
    Else
    Workbooks.Open filename:=ThisWorkbook.Path & “\” & unique(x) & “.xlsx”
    Set wb(x) = ActiveWorkbook
    End If

    For y = Strt To Stp
    If ws.Cells(y, uCol) = unique(x) Then
    ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
    wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial

    Paste:=xlPasteValuesAndNumberFormats
    End If
    Next y
    ‘autofit
    wb(x).Sheets(1).Columns.AutoFit
    wb(x).SaveAs ThisWorkbook.Path & “\” & unique(x) & “.xlsx”, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wb(x).Close SaveChanges:=True
    Else
    ‘Quit loop
    Exit For
    End If
    Next x

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ErrHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    End Sub

    Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
    CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
    End Function

    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
    [/code]

    This is a complete project and I use it at work.

    I am able to do this thanks mainly to guru Dinesh Kumar Takyar.

    Regards

    Raghu Prabhu

Leave a Reply

Your email address will not be published. Required fields are marked *