Speed Up Current Working Script - Transferring Data From One Sheet To Another

[ANG3L]

G'day,

I'm hoping someone can help me improve the speed of my script, it is currently working and does the job; however if you start getting above 1000 rows of data, it really takes some time to complete the operation. I can't improve the computers, but I figure someone might have a better and more efficient way of achieving the same task. All of my other code works smoothly and is very efficient, it is just this one piece that really slow.

Concisely, the script works as part of a larger script, and is designed to move data from the "Import Sheet" (Source) to a sheet that houses all the data for further reporting (Destination). In the first column on each sheet is an ID Code and in every column after that are dates that represent item movement. The script goes through each row on the Source Sheet and searches the Destination sheet for the ID Code, if it finds the ID Code it goes to the next blank column in that row and pastes the date from Source Sheet; sometimes each ID Code may have multiple dates, across multiple columns on the source sheet to move across. If the ID code isn't found on the Destination sheet, it goes to the next blank row and does the same as above inputting the dates.

Appreciate any help that may be given

Cheers ANG3L

Set Source = wbCopyTo.Sheets("#Sheet With Imported Data#")
Set Destination = wbCopyTo.Sheets("#Sheet that Imported Data Gets Sorted Into#")
Set DTGDATA = Source.Range("A3")
Set stFnd = Source.Range("A3")
Set n = Source.Range(stFnd, stFnd).End(xlToRight)
With Source
l = 0
ll = 0
    For Each r In Source.Range("A3", Source.Range("A3").End(xlDown))
        Set rFndCell = Destination.Range("b1:b10000").Find(stFnd, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rFndCell Is Nothing Then
        rRow = rFndCell.Row
              For Each c In Source.Range(stFnd, n)
                emptyColumn = Destination.Cells(rRow, Destination.Columns.Count).End(xlToLeft).Column
                If emptyColumn > 0 Then
                emptyColumn = emptyColumn + 1
                End If
                yRow = DTGDATA.Row
                yCol = DTGDATA.Column + 1
                Source.Cells(yRow, yCol).Copy
                Destination.Cells(rRow, emptyColumn).PasteSpecial xlPasteValues
                l = l + 1
                Set DTGDATA = Source.Range("A3").Offset(ll, l)
                Next c
        Else
        Set rFndCell = Destination.Range("b1:b10000").Find("", LookIn:=xlValues, LookAt:=xlWhole)
        rRow = rFndCell.Row
             For Each c In Source.Range(stFnd, n)
                emptyColumn = Destination.Cells(rRow, Destination.Columns.Count).End(xlToLeft).Column
                If emptyColumn > 0 Then
                emptyColumn = emptyColumn + 1
                End If
                yRow = DTGDATA.Row
                yCol = DTGDATA.Column
                Source.Cells(yRow, yCol).Copy
                Destination.Cells(rRow, emptyColumn).PasteSpecial xlPasteValues
                l = l + 1
                Set DTGDATA = Source.Range("A3").Offset(ll, l)
                Next c
        End If
        l = 0
        ll = ll + 1
        Set stFnd = Source.Range("A3").Offset(ll, 0)
        Set DTGDATA = Source.Range("A3").Offset(ll, 0)
        Set n = Source.Range(stFnd, stFnd).End(xlToRight).Offset(1, 0)
    Next r
End With

 

[ask2tsp]

Two things help
1. disable screen updates in the sub

sub ...
    Application.ScreenUpdating = False
...
...
    Application.ScreenUpdating = True
end sub

2. Don't use the clipboard for copying cells

'                Source.Cells(yRow, yCol).Copy
'                Destination.Cells(rRow, emptyColumn).PasteSpecial xlPasteValues
    'do it like this:
            
     Destination.Cells(rRow, emptyColumn).Value = Source.Cells(yRow, yCol).Value

you can optimize further using arrays, but these two are probably sufficient

 

[ANG3L]

G'day,

I already had screen updating turned off for the whole sub, but thanks for the suggestion. I implemented your second suggestion and it has decreased the time it take for the script to run, on 1000 lines of data, by about a minute, from 14.18 down to 13.22. I'm hoping there is a way to shrink this further, how much will arrays help and how would I go about implementing them?

Thank you for your time thus far.

 

[ask2tsp]

14 minutes! That is outrageous. Could you upload your workbook to some file sharing service (dropbox, onedrive) and publish the link in a reply. I will investigate why it takes so long (most likely the reading/updating of worksheet objects) and find a faster way (14 seconds?)

 

[ask2tsp]

Can you tell me the hardware (processor, memory) your workbook is running?
My machine runs an Intel core/i7 processor @2.4GHz with 8Gb memory.
I tested with 1260 rows on input sheet, 11 columns with dates; elapsed time 30 seconds.

 

[ANG3L]

It's an i5 @2.60 8Gb RAM. I did the same thing and got the same result. It appears running the code, with your changes, by itself is fast; however, when I add it to the larger script it slows down. I'm in the process of breaking the larger script down in to smaller Subs to see if i can find out why. I'll let you know if i find anything.