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

 

[mumps]

You could speed things up by filtering the data instead of using a loop. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your "Production" and "TransferedDATA" sheets. Alternately, you could upload a copy of your two files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Jirka79]

Hi mumps, I'm sorry, I'm not so sure how to use the XL2BB... So I will attach the pictures although you didn't want them :/

However, the point is very easy:

In Production data.xlsm the operators enter the daily production. They have eight rows for every shift and when the row is complete, and "X" appears in column AA.

When I open the All data.xlsm file, I execute the macro with the code of my first post. It copies all the rows that in AA contains X and paste them. But the code paste the data respecting the last pasted row, meaning that the macro never overwrites the data pasted before.

Of course the macro works fast when there is not so many data, but by the end of last year was really slow...

So, can somebody please give me some advice to speed it up? Thanks you all in advance!

 

[mumps]

Try:

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")
    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

Make sure that both workbooks are open before running the macro.

 

[Jirka79]

Hi again mumps,

The code worked really fast... but it copies all the X rows from Production data.xlsm and paste ALL of them in the file all data.xlsm without respecting the last value entered.

I mean, if for example in the "all data.xlsm" file the last row entered is from the shift "30/6/2022 6:01:00 to 30/6/2022 14:00:00" that started the production at 30/6/2022 8:13:09 and finished at 30/6/2022 9:57, the next expected row to be pasted should be the one containing the production that started at 30/6/2022 9:59 and finished 30/6/2022 11:16, but your code paste again all the rows from the very beggining of the file "Production data.xlsm" that contains the "X".

This is why in my code I have the instruction:

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

Because searches the dates that are in the L column and looks for the last entered date.

I'm afraid that this is the part that is making the code run really slow.... :/ I don't know if there is a way to change this in a faster way... :/

 

[mumps]

Are the Batch numbers in column F unique?

 

[Jirka79]

No... Unfortunately the batch number can appear two Times because if one shift doesnt finish it, the following shift will do it...

The only unique values are in columns K and L because the operators are executing a macro that enters the time at that very moment (date dd/mm/yy and time hh:mm:ss)

 

[Jirka79]

Now I'm thinking... What if there is a chance to change my first code by limiting the search in the loop? The loop is looking within the entire L and AA columns, but could be limited to the actual date minus 7 days, because it never takes me more than 7 days to update the file.

If I have the actual date let's say in cell V1 with the formula =Now() , is there a way to use the actual date and compare it with the dates that are in column A and limit the search of the loop within the last 7 days?

Maybe I'm complicating still more the code, but I just wanted to share my idea as a brainstorming in case you could think that this would help to speed up the macro...

 

[kevin9999]

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

 

[mumps]

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