Copy data only from last used row from multiple excel workbooks in a folder and paste into master file

[Reetesh]

i'm trying to come up with a code which copies data from last rows of multiple workbooks in a folder and paste into another workbook(Master file). The below mentioned code copies the complete data present in all the workbooks in the folder and paste it into another workbook without any issues:

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook

MyDir = "C:\Users\Jeevesh\Desktop\Dump\New folder\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Activity Data")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 9))
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, -1)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub

Now i'm not able to make changes to the code which will only copy the last used row from all the workbooks present in the folder and paste it into another workbook.

 

[mehidy1437]

Try with below,

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook

MyDir = "C:\Users\Jeevesh\Desktop\Dump\New folder\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Activity Data")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, -1)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub

 

[Reetesh]

Hello Mehidy1437,
Thanks for your help and the code works like a charm and exactly does what i want.

However there is one more help if you don't mind that i need. As i'm fairly new to VBA, not sure whether it could be done or not.

The copied data in the last row from all the workbooks in the folder, should be pasted at the top row(as in the the 2nd row,obviously below the Headers).
I'll explain in more detail what i want.
The master file, wherein i've used the above mentioned code, will have previous data existing in it as well. Now what i want is, whenever i run the above mentioned code, the data which the code will copy from the last row of all the workbooks in the folder, should be pasted at the top (again below the headers) after inserting a new row, so that the latest data should appear on the top of the master workbook (again below the Headers).

I've tried using the below code however it doesn't work. Instead of inserting the row in the master workbook, its doing it on the other workbooks:

Rows("2:2").Select
Range("B2").Activate
Selection.Insert Shift:=xlDown
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, -1)

Thanks for you help, Really Appreciated!!!!!!

 

[mehidy1437]

Try with below,

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook

MyDir = "C:\Users\Jeevesh\Desktop\Dump\New folder\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
On Error Resume Next
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Activity Data")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
Wb.Worksheets("Sheet1").Range("A2").EntireRow.Insert
Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub

 

[Reetesh]

Thank you so much for you help again mate... Its working perfect...exactly how i want....
Appreciate your help!

 

[mehidy1437]

Glad to know that it's work for you.

Here is another workaround,

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook

MyDir = "C:\Users\Jeevesh\Desktop\Dump\New folder\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
'On Error Resume Next
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Activity Data")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
'Wb.Worksheets("Sheet1").Range("A2").EntireRow.Insert
'Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
Rng.Copy
Wb.Worksheets("Sheet1").Range("A2").Rows("1:1").Insert Shift:=xlDown
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub

 

[Reetesh]

Thanks again mate... i'll be giving it a try with this one as well..

 

[Reetesh]

Hello mehidy1437,

I just noticed something and it was my fault that i missed on noticing it earlier before asking the question.
The code works perfectly. However there is one small issue. If one of the workbook in the folder does not have any data in it, just contains Headers, then the code is reading/considering the header as the Last Used Row and then copies the header in the masterfile in between the data. Is there any work around for this???

Thanks in advance for your help mate!!!

 

[mehidy1437]

How many rows, do you have in the blank book including the header row?
The below code is considering only one row for the header, you can change the Ndt number if there is more than 1 row.

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range, Ndt As Integer

Set Wb = ThisWorkbook

MyDir = "C:\Users\Jeevesh\Desktop\Dump\New folder\"

MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
'On Error Resume Next
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Activity Data")
Ndt = .UsedRange.Rows.Count
    If Ndt = 1 Then
    'do nothing
    ActiveWorkbook.Close True
    Else
    
        Rws = .Cells(Rows.Count, "B").End(xlUp).Row
        Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
        'Wb.Worksheets("Sheet1").Range("A2").EntireRow.Insert
        'Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
        Rng.Copy
        Wb.Worksheets("Sheet1").Range("A2").Rows("1:1").Insert Shift:=xlDown
        ActiveWorkbook.Close True
    
    End If

End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub

 

[Reetesh]

Hello Mate. There is only 1 row of header on all the workbooks and I think the code which you mentioned above its working perfectly... will give it a try will multiple workbooks (Only tried with 4 workbooks as if now, and it works perfectly).

Thanks a lot again mate. I believe i wont come back with some new problem ?.