Fastest way to transfer large amounts of data between worksheets - excel

Question

I currently have 2 worksheets, for simplicity sake let's call them Sheet1 and Sheet2 in the explanations. In Sheet1 I have around 50k rows of data. I am trying to go through Sheet1 and find unique occurrences in the data set to then transfer across to Sheet2.
Below are the methods I have used so far and their rough estimates for time taken.
Method A - Iterate through Sheet1 with a For loop with the conditional check programmed in VBA, if condition is met - transfer a range of 8 cells on that row to Sheet2. This method completes 60% in 60 minutes.
Method B - I thought that removing the condition check in VBA could speed things up so I created a new column in Sheet1 with an IF statement that returns "Y" if the condition is met. I then iterate through this column and if there is a "Y" - transfer the occurrence across to Sheet2. This weirdly takes longer than method A, namely 50% in 60 mins.
Sub NewTTS()
Dim lRow1 As Long, lRow2 As Long
Dim i As Long
With wsOTS
lRow1 = .Range("E" & .Rows.Count).End(xlUp).Row
For i = lRow1 To 2 Step -1
If .Range("P" & i).Text = "Y" Then
lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1
wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = .Range("E" & i, "AA" & i).Value
End If
Next i
End With
End Sub
Method C - I then read on another post that the .Find() method is quicker than using For loop method. As such I used a .Find() in the column that returns the "Y" and then transfer event across to Sheet2. This is the fastest method so far but still only completes 75% in 60 mins.
Sub SearchOTS()
Application.ScreenUpdating = False
Dim startNumber As Long
Dim lRow1 As Long, lRow2 As Long
Dim i As Long
Dim startTime As Double
startTime = Time
lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row
Columns("P:P").Select
Selection.Find(What:="Y", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
startNumber = ActiveCell.Row
lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1
wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = wsOTS.Range("E" & ActiveCell.Row, "AA" & ActiveCell.Row).Value
For i = 1 To lRow1
Selection.FindNext(After:=ActiveCell).Activate
If ActiveCell.Row = startNumber Then GoTo ProcessComplete
lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1
wsTTS.Range("E" & lRow2, "AA" & lRow2).Value = wsOTS.Range("E" & ActiveCell.Row, "AA" & ActiveCell.Row).Value
wsOTS.Range("B18").Value = i / lRow1
Next i
ProcessComplete:
Application.ScreenUpdating = True
MsgBox "Complete! Time taken: " & Format(Time - startTime, "hh:mm:ss")
End Sub
Method D - I then read another post saying that the fastest way would be to build an array and then loop through the array. Instead of an array I used a collection (dynamic), and I iterate through Sheet1 and store the row numbers for the occurences. I then loop through the collection and transfer the events across to Sheet2. This method returns 50% in 60 mins.
Sub PleaseWork()
Dim i As Long
Dim lRow1 As Long, lRow2 As Long
Dim myCol As New Collection
lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row
'build collection of row numbers
For i = 1 To lRow1
If wsOTS.Range("P" & i).Text = "Y" Then
myCol.Add i
End If
Next i
'now go through collection and build TTS
For i = 1 To myCol.Count
lRow2 = wsTTS.Range("E" & wsTTS.Rows.Count).End(xlUp).Row + 1
wsTTS.Range("E" & lRow2, "N" & lRow2).Value = wsOTS.Range("E" & myCol(i), "N" & myCol(i)).Value
Next i
Set myCol = New Collection
End Sub
I am trying to find the fastest way to complete this task but all the methods I have tried are yielding greater than an hour to complete.
Is there anything I am missing here? Is there a faster method?

Answer 1

Accessing a range is abysmally slow, and the cause for your long runtime. If you already know that you are going to read 1000 rows, do not read them one at a time. Instead, pull the whole range in a buffer, then work only with that buffer. Same goes for writing. If you do not know in advance how much you will write, make chunks of e.g. 100 rows length.
(Untested) example:
Sub PleaseWork()
Dim i As Long, j as long
Dim lRow1 As Long, lRow2 As Long
Dim myCol As New Collection
Dim column_p() as variant
dim inbuffer() as Variant
dim outbuffer() as variant
lRow1 = wsOTS.Range("E" & wsOTS.Rows.Count).End(xlUp).Row
' Get whole Column P at once
column_p = wsOTS.Range("P1").Resize(lRow1, 1).Value
'build collection of row numbers
For i = 1 To lRow1
If column_p(i, 1) = "Y" Then
myCol.Add i
End If
Next i
'now go through collection and build TTS
lRow2 = myCol.Count 'Number of required rows
' get whole input range
inbuffer = wsOTS.Range("E1").Resize(lRow1, 10).Value
' prepare output
ReDim outbuffer(1 to lRow2, 1 to 10)
For i = 1 To myCol.Count
' write into outbuffer
for j = 1 to 10
outbuffer(i, j) = inbuffer(myCol(i), j)
Next
Next i
' Set whole output at once
wsTTS.Range("E1").Resize(lRow2, 10).Value = outbuffer
Set myCol = New Collection
End Sub

Answer 2

did you consider using Remove Duplicates.
Steps:
Copy entire data to a new sheet
On Data tab, choose Remove duplicates
You can record this as a macro as well.