VBA Remove duplicates taking 30 minutes to run with no idea why - excel

Question

So the code below copies data from two columns in one sheet. Pastes these so that values are displayed in another sheet (because one column is a formula =Left(Column+1,4)) and then attempts to run a remove duplicates across the two columns that are pasted.
This takes roughly 30 minutes to run on what is essentially 100k cells (2 columns of 50k rows each).
This is what I've been using
Sub ProjTrending1()
Dim s1 As Worksheet, s2 As Worksheet
Dim St As Date, Et As Date
Dim Tt As Double
St = Time
Application.ScreenUpdating = False
'Defines S1 as a Worksheet
Set s1 = Sheets("All Data")
'Defines S2 as WorkSheet
Set s2 = Sheets("Workings")
'Defines LastR1
Dim LR1 As Long
Dim LR2 As Long
'Finds last row cell working sheet
LR2 = s1.Cells(Rows.Count, 10).End(xlUp).Row
'Takes Data from Order Column of defined data Sheet and copy & pastes it to Working Sheet Column B
s1.Range("J1:J" & LR2).Copy s2.Range("A1")
s1.Range("e1:e" & LR2).Copy
s2.Range("b1").PasteSpecial Paste:=xlPasteValues
LR1 = s2.Range("A1").CurrentRegion.Rows.Count
'Removes Duplicates from Column B Working sheet
s2.Range("A2:B" & LR1).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
'Copies the formula from C2 and applies it to all cells in column C where column A has values (simple concatenate + countifs(B$2:B2,B2)
s2.Range("C2").Copy s2.Range("C2:C" & LR1)
Et = Time
Tt = (Et - St) * 24 * 60 * 60
MsgBox Timetaken
End Sub
I've also tried using a dictionary to do this but I'm new to dictionaries so whilst the code looks good compared to my usual attempts its because its taken from a couple of different sources. (Copied and Pasted the data to sheet2 incase this overwrote the source data)
Sub M_delete_duplicates()
sn = Sheets("Sheet2").Cells(1).CurrentRegion.Resize(, 5)
With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = Application.Index(sn, j, 0)
Next
Sheets("Sheet2").Cells(1, 4).Resize(.Count, UBound(sn, 2)) = Application.Index(.Items, 0, 0)
End With
End Sub
This is as slow to run and it only does remove duplicates based on single column and I need it to operate on two columns. The potential way around this is to concatenate the two columns of data and run the remove duplicates once and then break the data using =right(Value,X)
If wanted to do it manually it takes 30 seconds max. It makes no sense to me as to why it takes so long to run.
Can anyone help with why this might be taking so long to run? and how I might modify the dictionary code to remove duplicates over two columns?
Thanks in advance

Answer 1

Updated from my comment. This uses a dictionary to track which rows have been added and then copies unique rows across to the destination sheet. You may want to modify it a bit for your use (e.g. update sheet names) Always test this first on a copy of your data set or make a back up before running code
Option Explicit
Public Sub ExampleRemoveDuplicates()
Dim dict As Object
Dim temp As String
Dim calc As String
Dim headers As Variant
Dim NoCol As Long, NoRow As Long, i As Long, j As Long
Dim c, key
With Application
.ScreenUpdating = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
Set dict = CreateObject("Scripting.Dictionary")
' Change this to the sheet that is applicable
With Sheet1
NoCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' Assumes first row of sheet is headers
headers = .Range(.Cells(1, 1), .Cells(1, NoCol)).Value2
' Change this to destination sheet
With Sheet2
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, NoCol)).Value2 = headers
End With
For Each c In .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
ReDim arr(1 To NoCol)
j = 1
Do
arr(j) = c.Offset(0, j - 1).Value2
j = j + 1
Loop Until j = NoCol + 1
temp = Join(arr, "//")
If Not dict.exists(temp) And Not temp = vbNullString Then
dict.Add key:=temp, Item:=arr
' Change this to destination sheet
With Sheet2
NoRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(NoRow, 1), .Cells(NoRow, NoCol)).Value2 = arr
End With
End If
Next c
End With
i = 1
ReDim Results(1 To dict.Count, 1 To NoCol)
For Each key In dict.keys
For j = 1 To NoCol
Results(i, j) = dict(key)(j)
Next j
i = i + 1
Next key
' Change this to destination sheet
With Sheet2.Cells(1, 1)
.Range(.Offset(1, 0), .Offset(dict.Count, NoCol - 1)) = Results
End With
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub