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]

It's okay, you can back always. If there are any issues.

 

[Reetesh]

Hello mehidy1437
Sorry to bother you again mate.
But I've made some changes to the code because the criteria have been changed a little.
The changes are that now I'm copying the last 2 used rows from all the works books present in the folder and pasting it into the master file after inserting 2 new rows instead of one at the top (below the Headers).
Below are the changes to the codes highlighted in bold, which I Made as far as i understood.

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-1 '' so that it goes on the second last used row
Set Rng = Range((.Cells(Rws, 1)+1), .Cells(Rws, 9)) ''for the code to consider 2 last used row on all the workbooks
Wb.Worksheets("Sheet1").Range("A2").EntireRow.Insert
Wb.Worksheets("Sheet1").Range("A2").EntireRow.Insert ''For inserting 2 new rows at the top of the sheet below the headers instead of one
Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop

End Sub


I know i must have done something dumb with the changes which I made to the codes, but made the changes as a layman would ?

Now the problem which I'm facing is that, I want the data to be pasted as upside down in the master file. I'll try to explain with an example.

So the code is copying the last 2 used rows from all the work books, lets name the Second last as "Row1" and Last Row as "Row 2".
Now when data is getting pasted on the master file, instead of the copying the Row 1 first and Row 2 after that, I want Row 2 to be pasted first and after that Row 1 right below it.

I know i'm asking for lot, but was not sure whether this could be done or not. So just thought of asking the Expert

Thanks in advance Mate.

 

[mehidy1437]

Try with this,

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim Arr As Variant
Dim i As Integer, j As Integer, k As Integer
    
Set Wb = ThisWorkbook

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

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableAnimations = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With
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, 1), .Cells(Rws, 9)) ''for the code to consider 2 last used row on all the workbooks
Arr = Rng.Formula
    For j = 1 To UBound(Arr, 2)
        k = UBound(Arr, 1)
            For i = 1 To UBound(Arr, 1) / 2
                xTemp = Arr(i, j)
                Arr(i, j) = Arr(k, j)
                Arr(k, j) = xTemp
                k = k - 1
            Next
    Next
    Rng.Formula = Arr
Wb.Worksheets("Sheet1").Range("A2:A3").EntireRow.Insert
Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
ActiveWorkbook.Close False
End With
MyFile = Dir()
Loop

On Error GoTo 0
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

Done:
Exit Sub

End Sub

 

[Reetesh]

Its Perfect Mate.
Its doing what i exactly asked for.

However, there is one small problem which I'm facing and again its my fault that i didn't think about it earlier.
If in any of the workbooks there is only single row of data below the header, then the code is copying the headers as well with that last used row.
There is only one row of header in all the workbooks
I was using the below mentioned code which you helped me with earlier:

With Worksheets("Activity Data")

Ndt = .UsedRange.Rows.Count
If Ndt = 1 Then
'do nothing
ActiveWorkbook.Close True
Else

However, its considering and copying both the rows "Set Rng = Range(.Cells(Rws - 1, 1), .Cells(Rws, 9)) " here.

Sorry for being a pain again mate.
i'll be grateful, If you could help me with this.
Thanks

 

[Reetesh]

Also there is one more thing i forgot to mention.
All the workbooks in the folder are protected.
Because i was getting an Run-Time Error '1004' that the sheet is protected.

 

[mehidy1437]

So, workbooks are protected only, but sheets are non protected, right?

 

[Reetesh]

Sorry my bad.... the worksheet "Activity Data" is protected as well

 

[mehidy1437]

See if this okay or not? It's work on my test.
Change the password
Change the file path

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim Arr As Variant
Dim i As Integer, j As Integer, k As Integer
    
Set Wb = ThisWorkbook
Dim wb2 As Workbook

MyDir = "C:\Users\mehidy\Desktop\New folder (2)\New folder (2)\" 'change the path
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableAnimations = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With
On Error Resume Next

Do While MyFile <> ""
'Workbooks.Open (MyFile)
Set wb2 = Workbooks.Open(MyFile, Password:="book12345") 'change the password

With Worksheets(" Activity Data")
Rws = .Cells(Rows.Count, "B").End(xlUp).Row

If Rws = 1 Then
        'do nothing
        ActiveWorkbook.Close False
ElseIf Rws = 2 Then
        Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
        Rng.Copy
        Wb.Worksheets("Sheet1").Range("A2").Rows("1:1").Insert Shift:=xlDown
        ActiveWorkbook.Close False
Else
        Set Rng = Range(.Cells(Rws - 1, 1), .Cells(Rws, 9)) ''for the code to consider 2 last used row on all the workbooks
        Arr = Rng.Formula
            For j = 1 To UBound(Arr, 2)
                k = UBound(Arr, 1)
                    For i = 1 To UBound(Arr, 1) / 2
                        xTemp = Arr(i, j)
                        Arr(i, j) = Arr(k, j)
                        Arr(k, j) = xTemp
                        k = k - 1
                    Next
            Next
            Rng.Formula = Arr
        Wb.Worksheets("Sheet1").Range("A2:A3").EntireRow.Insert
        Rng.Copy Wb.Worksheets("Sheet1").Range("A2").EntireRow
        ActiveWorkbook.Close False
End If
End With
MyFile = Dir()
Loop

On Error GoTo 0
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

Done:
Exit Sub

End Sub

 

[Reetesh]

Hello Mate,

I've tried the code after changing the password and the file path.
However its not copying the data on the master workbook.

the code does open the all the workbooks in the folder though.

 

[Reetesh]

I believe the code is not considering the below mentioned steps:

ElseIf Rws = 2 Then
Set Rng = Range(.Cells(Rws, 1), .Cells(Rws, 9))
Rng.Copy
Wb.Worksheets("Sheet1").Range("A2").Rows("1:1").Insert Shift:=xlDown
ActiveWorkbook.Close False

I've tried to run the code step by step, it does not consider the above mentioned while doing so