Speed up copied data from one Excel file and paste it to another one

[Jirka79]

Hi,

I have the attached code that copies the data from one excel file and copy it to another one. This data is daily increased, so when I copy it, then needs to be paste it starting from the last time that was updated.

I have the feeling that is taking too much time and maybe there is way to speed it up. Could somebody please take a look and give me some advice?

Thank you all in advance!!

Sub transferDATA()

Dim StRo As Integer, T As Integer, Ro2 As Integer, Lr As Integer

If Range("AA1").Value = 1 Then

Application.ScreenUpdating = False
Application.EnableEvents = False
Workbooks("Production data.xlsm").Worksheets("Production").Activate
ActiveSheet.Unprotect Password:="123"
With Sheets("Production")
M = Workbooks("All data.xlsm").Worksheets("TransferedDATA").UsedRange.Rows.Count

If Workbooks("All data.xlsm").Worksheets("TransferedDATA").UsedRange.Rows.Count = 1 Then
.Range("A4:Z4").Copy Workbooks("All data.xlsm").Worksheets("TransferedDATA").Range("A4")
StRo = .Range("AA:AA").Find("X").Row
Lr = 4
Else
Lr = Workbooks("All data.xlsm").Worksheets("TransferedDATA").Range("L" & Rows.Count).End(xlUp).Row
StRo = .Range("L:L").Find(Workbooks("All data.xlsm").Worksheets("TransferedDATA").Range("L" & Lr)).Row + 1
End If

For T = StRo To .Range("A" & Rows.Count).End(xlUp).Row
    If .Range("AA" & T) = "X" Then
    Ro2 = Ro2 + 1
    Workbooks("All data.xlsm").Worksheets("TransferedDATA").Range("A" & Lr + Ro2 & ":Z" & Lr + Ro2).Value = .Range("A" & T & ":Z" & T).Value
    End If
      
Next T

End With
Application.ScreenUpdating = True
Application.EnableEvents = True

Workbooks("All data.xlsm").Worksheets("TransferedDATA").Activate
Else
Exit Sub
End If

End Sub

 

[Jirka79]

I'm a bit late to this party, but I thought I'd offer the following to try on a copy of your data.

Option Explicit
Sub Jirka79()
    Application.ScreenUpdating = False
    Dim wbSrc As Workbook, wsSrc As Worksheet, wsDest As Worksheet
    Dim lrSrc As Long, lrDest As Long, lrTime As Long, DateFilter As Date
   
    Set wbSrc = Workbooks("Production data")
    Set wsSrc = wbSrc.Worksheets("Production")
    Set wsDest = ThisWorkbook.Worksheets("TransferedDATA")
   
    lrDest = wsDest.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    lrTime = wsDest.Cells(Rows.Count, 1).End(3).Row
    lrSrc = wsSrc.Cells.Find("*", , xlFormulas, , 1, 2).Row
    DateFilter = Application.Max(wsDest.Columns("A:A"))
   
    With wsSrc.Range("A4:AA" & lrSrc)
        .AutoFilter 1, ">" & CLng(DateFilter)
        .AutoFilter 27, "X"
        .Offset(1).Resize(, 19).Copy wsDest.Range("A" & lrDest)
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub

Hi Kevin,

Party is not over, so you are welcomed :D

Your code worked pretty fast, but there are three buts:

1- The values pasted have to be without formats. What can be changed in your code in order to paste just values?
2- The sheet called "TransferedData contains formulas starting in column AA and finishing in column AE. Your code paste the values to the next row completly empty, where are no formulas. In my case the rows got pasted in row 9000 because the formulas are up to that row. Is there a way to avoid this? In case that it can not be possible, I will add the formulas in another sheet. Not a big issue here.
3- When I ran the code in an extended file with more data, I realized that didn't respect the last value entered already in the sheet "transferedData". If the last row appearing in the "TransferedData" is from the middle of one shift, it then pastes the rows from the whole shift. Is there a way to avoid this?

 

[Jirka79]

See if this works for you:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Workbooks("Production data.xlsm").Sheets("Production")
    Set desWS = ThisWorkbook.Sheets("TransferredDATA")
    desWS.UsedRange.Offset(2).ClearContents
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With srcWS
        .Range("AA5", .Range("AA" & .Rows.Count).End(xlUp)).AutoFilter 1, "X"
        .Range("A5", .Range("S" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy desWS.Range("A" & LastRow)
        .Range("AA5").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Hi again mumps!

This new code is the fastest by far!!!

However have also some but's :/

1-You erase the whole data in the TransferedDATA before to paste all the data in the Production sheet. This erases even the headers and starts pasting in cell A2. Could be possible to erase only the values starting from cell A5 up to cell S xxx and then starts pasting from cell A5? However, I'm not big fan to erase everything, I would prefer better to respect what is already in TransferedDATA sheet and starts pasting from the last row entered. But I understand that not everything is possible....
2- Also I need only the values to be pasted, without the formats. What have to chnaged in order to paste the values only?

Thank you again for your time and help!!

 

[kevin9999]

Hi Kevin,

Party is not over, so you are welcomed :D

Your code worked pretty fast, but there are three buts:

1- The values pasted have to be without formats. What can be changed in your code in order to paste just values?
2- The sheet called "TransferedData contains formulas starting in column AA and finishing in column AE. Your code paste the values to the next row completly empty, where are no formulas. In my case the rows got pasted in row 9000 because the formulas are up to that row. Is there a way to avoid this? In case that it can not be possible, I will add the formulas in another sheet. Not a big issue here.
3- When I ran the code in an extended file with more data, I realized that didn't respect the last value entered already in the sheet "transferedData". If the last row appearing in the "TransferedData" is from the middle of one shift, it then pastes the rows from the whole shift. Is there a way to avoid this?

It'll be a few hours before I can get to this - but all should be doable.

 

[Alex Blakenburg]

3- When I ran the code in an extended file with more data, I realized that didn't respect the last value entered already in the sheet "transferedData". If the last row appearing in the "TransferedData" is from the middle of one shift, it then pastes the rows from the whole shift. Is there a way to avoid this?

I think you are in good hands already so I will leave it to Kevin & mumps but it might be worth clarifying this.
@kevin9999 is using Column A to determine the new data ie date in column A of source > max value in column A of destination
If he changed that to being date AND time > Max Value of Date AND Time in column L (Hdg=End), would that pick up just the new data you are after ?

 

[kevin9999]

Hi Kevin,

Party is not over, so you are welcomed :D

Your code worked pretty fast, but there are three buts:

1- The values pasted have to be without formats. What can be changed in your code in order to paste just values?
2- The sheet called "TransferedData contains formulas starting in column AA and finishing in column AE. Your code paste the values to the next row completly empty, where are no formulas. In my case the rows got pasted in row 9000 because the formulas are up to that row. Is there a way to avoid this? In case that it can not be possible, I will add the formulas in another sheet. Not a big issue here.
3- When I ran the code in an extended file with more data, I realized that didn't respect the last value entered already in the sheet "transferedData". If the last row appearing in the "TransferedData" is from the middle of one shift, it then pastes the rows from the whole shift. Is there a way to avoid this?

OK. Points 1 & 2 I think I've covered fairly easily. With regard to point 3, see if the amended code below addresses that (using @Alex Blakenburg 's advice in post #14 as guidance - I think I've got that right Alex).

Option Explicit
Sub Jirka79_2()
    Application.ScreenUpdating = False
    Dim wbSrc As Workbook, wsSrc As Worksheet, wsDest As Worksheet
    Dim lrSrc As Long, lrDest As Long, lrTime As Long
    Dim DateFilter1 As Date, DateFilter2 As Date
    
    Set wbSrc = Workbooks("Production data")
    Set wsSrc = wbSrc.Worksheets("Production")
    Set wsDest = ThisWorkbook.Worksheets("TransferedDATA")
    
    lrDest = wsDest.Cells.Find("*", , xlValues, , 1, 2).Row + 1
    lrTime = wsDest.Cells(Rows.Count, 1).End(3).Row
    lrSrc = wsSrc.Cells.Find("*", , xlFormulas, , 1, 2).Row
    DateFilter1 = Application.Max(wsDest.Columns("A:A"))
    DateFilter2 = Application.Max(wsDest.Range("L5", Cells(Rows.Count, "L").End(xlUp)))
    
    With wsSrc.Range("A4:AA" & lrSrc)
        .AutoFilter 1, ">" & CLng(DateFilter1)
        .AutoFilter 12, ">" & CLng(DateFilter2)
        .AutoFilter 27, "X"
        .Offset(1).Resize(, 19).Copy
        wsDest.Range("A" & lrDest).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

Because it's date and time and partial day transfers are possible I think it might need to use CDbl

.AutoFilter 12, ">" & CDbl(DateFilter)

I am a bit paranoid about working with times and was even considering something like:

.AutoFilter 12, ">" & Application.RoundUp(CDbl(DateFilter), 6)

(1 sec is something like 0.00001157407)

 

[mumps]

This should do it:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    'Set srcWS = Workbooks("Production data.xlsm").Sheets("Production")
    Set srcWS = Sheets("Production")
    Set desWS = ThisWorkbook.Sheets("TransferredDATA")
    desWS.Range("A5", desWS.Range("S" & Rows.Count).End(xlUp)).ClearContents
    With srcWS
        .Range("AA5", .Range("AA" & .Rows.Count).End(xlUp)).AutoFilter 1, "X"
        .Range("A5", .Range("S" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
        desWS.Range("A5").PasteSpecial xlPasteValues
        .Range("AA5").AutoFilter
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Jirka79]

Hi Kevin and mumps, I'm just writing you to apologize because I'm in a business trip and I can't chech your codes at the moment. I will come back to you next Monday!

Thanks you all for your support!!

 

[Jirka79]

OK. Points 1 & 2 I think I've covered fairly easily. With regard to point 3, see if the amended code below addresses that (using @Alex Blakenburg 's advice in post #14 as guidance - I think I've got that right Alex).

Option Explicit
Sub Jirka79_2()
    Application.ScreenUpdating = False
    Dim wbSrc As Workbook, wsSrc As Worksheet, wsDest As Worksheet
    Dim lrSrc As Long, lrDest As Long, lrTime As Long
    Dim DateFilter1 As Date, DateFilter2 As Date
   
    Set wbSrc = Workbooks("Production data")
    Set wsSrc = wbSrc.Worksheets("Production")
    Set wsDest = ThisWorkbook.Worksheets("TransferedDATA")
   
    lrDest = wsDest.Cells.Find("*", , xlValues, , 1, 2).Row + 1
    lrTime = wsDest.Cells(Rows.Count, 1).End(3).Row
    lrSrc = wsSrc.Cells.Find("*", , xlFormulas, , 1, 2).Row
    DateFilter1 = Application.Max(wsDest.Columns("A:A"))
    DateFilter2 = Application.Max(wsDest.Range("L5", Cells(Rows.Count, "L").End(xlUp)))
   
    With wsSrc.Range("A4:AA" & lrSrc)
        .AutoFilter 1, ">" & CLng(DateFilter1)
        .AutoFilter 12, ">" & CLng(DateFilter2)
        .AutoFilter 27, "X"
        .Offset(1).Resize(, 19).Copy
        wsDest.Range("A" & lrDest).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub

Hi Kevin!

I have just tried your code and it works pretty fast, the only issue here is that doesn't find correctly the last value entered. I attach you a picture just to show you that your macro has pasted the values skipping the ones marked in red colour.

Before to exectute the macro, the last entered value was from the morning shift, and the production was from 05/07/2022 at 13:21 to 05/07/2022 at 13:·39. Once I executed the macro, it worked fine, but skipped the rows that I have marked you in red colour. The next expected row was from the production that started at 05/07/2022 at 14:09 to 05/07/2022 at 15:19 and so on, but your macro pasted the values from the production 05/07/2022 at 23:48 to 06/07/2022 1:06 skipping the previous mentioned rows.

Do you know why this is happening?

 

[kevin9999]

Hi Kevin!

I have just tried your code and it works pretty fast, the only issue here is that doesn't find correctly the last value entered. I attach you a picture just to show you that your macro has pasted the values skipping the ones marked in red colour.

Before to exectute the macro, the last entered value was from the morning shift, and the production was from 05/07/2022 at 13:21 to 05/07/2022 at 13:·39. Once I executed the macro, it worked fine, but skipped the rows that I have marked you in red colour. The next expected row was from the production that started at 05/07/2022 at 14:09 to 05/07/2022 at 15:19 and so on, but your macro pasted the values from the production 05/07/2022 at 23:48 to 06/07/2022 1:06 skipping the previous mentioned rows.

Do you know why this is happening?

Try changing the Clng(Filter.. lines to CDbl(Filter... as per Alex's suggestion in post #16 and see if that gives the correct result.

Unfortunately, I'm about to head overseas for a couple of weeks so I'll only be accessing Mr Excel remotely (away from my laptop). If the above suggestion doesn't work, hopefully @Alex Blakenburg will be able to assist you further (thanks Alex )
Kind regards
Kevin