Need Macro for copy part of excel sheet rows and columns and paste in other file

[preethi3290]

Hi,
I have a main folder containing 25 sub folders. daily I will add one new excel sheet to each sub folder. I want to copy part of the Excel sheet data from 25 excel sheets which are in 25 sub folders and paste in a new master excel sheet.
Then I have to upload the master excel sheet in MS Access.
I am using the below Macro for copying the part of data and paste in master sheet.

Sub copy()
Application.DisplayAlerts = False
Dim i As Integer, erow As Integer, LastRow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 16 To LastRow
If Cells(i, "J") = Date Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.copy
Workbooks.Open Filename:="C:\Users\preet\Desktop\latest\preethi3.xlsx"
Worksheets("sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If

Next i
MsgBox ("Task completed")
End Sub



This Macro is copying data pasting in new master sheet. But the Problem is when I am processing Macro in second sheet it is copying the sheet data to master sheet but the first sheet data is changing values.

Please see the attached sample excel sheet(Preethi sheet) and master sheet(preethi3).

 

[AlanSidman]

Step through your code using the F8 key and look at each step and determine that the code is doing exactly what you expect if you were to do it manually. This is called debugging your code. Click on the link in my signature block to better understand this. If you are going to use code in Excel, this is a key step to being a better developer and understanding what exactly your code is doing.

 

[preethi3290]

Step through your code using the F8 key and look at each step and determine that the code is doing exactly what you expect if you were to do it manually. This is called debugging your code. Click on the link in my signature block to better understand this. If you are going to use code in Excel, this is a key step to being a better developer and understanding what exactly your code is doing.

Hi,
Thanks for your reply.
My code is copying the data correctly but I don't know the reason why it is changing the values of master sheet which are already saved.

 

[AlanSidman]

I've run your code. I don't see any changes being made to the sheet. Perhaps you could be more explicit in your explanation of what changes.

BTW: Your code seems a bit inefficient. Why only copy one line at a time and not copy from row 16 to the last row at one time and paste it. what is the advantage of copying and pasting multiple times and then opening and closing the target file multiple times. The screen flashing is quite distracting.

 

[preethi3290]

Hi, can you please send the code to copy at a time and pate

 

[AlanSidman]

Option Explicit

Sub copy()
Application.DisplayAlerts = False
Dim i As Integer, erow As Integer, LastRow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 16 To LastRow
If Cells(i, "J") = Date Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.copy
Workbooks.Open Filename:="C:\Users\preet\Desktop\latest\preethi3.xlsx"
Worksheets("sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False

MsgBox ("Task completed")
End Sub

I re-read the code and realized you cannot loop as you have a Date requirement. I did amend your code slightly so that it does not save and close the target file until after the last row is copied.
Move your workbooks open line to above the loop as you only need to open it once.

 

[preethi3290]

Option Explicit

Sub copy()
Application.DisplayAlerts = False
Dim i As Integer, erow As Integer, LastRow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 16 To LastRow
If Cells(i, "J") = Date Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.copy
Workbooks.Open Filename:="C:\Users\preet\Desktop\latest\preethi3.xlsx"
Worksheets("sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False

MsgBox ("Task completed")
End Sub

I re-read the code and realized you cannot loop as you have a Date requirement. I did amend your code slightly so that it does not save and close the target file until after the last row is copied.
Move your workbooks open line to above the loop as you only need to open it once.

The above code is copying only first row of the column

 

[AlanSidman]

I've modified your code and when I run it, it copies all current date data to the #3 file.

Sub copy()
    Application.DisplayAlerts = False
    Dim s As Workbook
    Dim t As Workbook
    Set s = ActiveWorkbook
    Dim i As Long, erow As Long, LastRow As Long, lrt As Long
    Dim tName As String
    Dim tPath As String
    LastRow = s.Sheets("Laundromat Invoice").Range("A" & Rows.Count).End(xlUp).Row
    tName = "preethi3.xlsx"
    tPath = "C:\Users\Alan\Desktop\"  'latest\
    Set t = Workbooks.Open(tPath & tName)
    For i = 16 To LastRow
        lrt = t.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        If s.Sheets("Laundromat Invoice").Cells(i, "J") = Date Then
            s.Sheets("Laundromat Invoice").Range("B" & i & ":L" & i).copy t.Sheets("Sheet1").Range("A" & lrt + 1)
        End If
    Next i
    t.Save
    t.Close
    Application.CutCopyMode = False
    MsgBox ("Task completed")
End Sub

 

[preethi3290]

I've modified your code and when I run it, it copies all current date data to the #3 file.

Sub copy()
    Application.DisplayAlerts = False
    Dim s As Workbook
    Dim t As Workbook
    Set s = ActiveWorkbook
    Dim i As Long, erow As Long, LastRow As Long, lrt As Long
    Dim tName As String
    Dim tPath As String
    LastRow = s.Sheets("Laundromat Invoice").Range("A" & Rows.Count).End(xlUp).Row
    tName = "preethi3.xlsx"
    tPath = "C:\Users\Alan\Desktop\"  'latest\
    Set t = Workbooks.Open(tPath & tName)
    For i = 16 To LastRow
        lrt = t.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        If s.Sheets("Laundromat Invoice").Cells(i, "J") = Date Then
            s.Sheets("Laundromat Invoice").Range("B" & i & ":L" & i).copy t.Sheets("Sheet1").Range("A" & lrt + 1)
        End If
    Next i
    t.Save
    t.Close
    Application.CutCopyMode = False
    MsgBox ("Task completed")
End Sub

Hi,
This code is not copying the data

 

[AlanSidman]

This code works perfectly with the sample you supplied. For me to ensure it was working, I had to change the path to my machine. Did you notice this and did you bother to change the path to your machine? Did you get an error. If so, what was the error code and which line of code was highlighted when you ran the debug. Help us to help you. We are not mindreaders.

This code is not copying the data

does not help us to solve your issue.