Excel VBA删除重复项需要30分钟运行，不知道原因

下面的代码将两列数据复制到一张表中。粘贴这些值，以便在另一张图纸中显示值（因为一列是公式=左（列+1,4）），然后尝试在粘贴的两列之间运行删除重复项

这大约需要30分钟才能在基本上为100k的单元格上运行（2列，每列50k行）

这就是我一直在用的

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

我也尝试过使用字典来实现这一点，但我对字典还不熟悉，所以虽然代码与我通常的尝试相比看起来不错，但这是因为它来自两个不同的来源。（将数据复制并粘贴到表2，以防改写源数据）

端接头

这是缓慢的运行，它只删除重复的基础上单一列，我需要它对两列操作。解决这一问题的潜在方法是连接两列数据，运行一次删除重复项，然后使用=right（Value，X）中断数据

如果要手动操作，最多需要30秒。我不明白为什么要运行这么长时间

有谁能帮我解释一下为什么这可能需要这么长时间？以及如何修改字典代码以删除两列上的重复项

---

提前感谢

根据我的评论更新。这将使用字典跟踪已添加的行，然后将唯一的行复制到目标工作表。您可能需要对其进行一些修改以供使用（例如，更新工作表名称）请务必先在数据集的副本上进行测试，或在运行代码之前进行备份

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

它和你所说的使用字典一样

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