Sub tt()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Cells(2, 1).Resize(Cells(Rows.Count, 1).End(3).Row).Clear
    With Sheets("Лист2")
        .Range("A2:A" & .Cells(.Rows.Count, 1).End(3).Row).Copy
    End With
    Cells(2, 1).PasteSpecial Paste:=xlPasteValues
    With Sheets("Лист3")
        .Range("A2:A" & .Cells(.Rows.Count, 1).End(3).Row).Copy
    End With
    Cells(Cells(Rows.Count, 1).End(3).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
    r1_ = Cells(Rows.Count, 1).End(3).Row
    ActiveSheet.Range("A2:A" & r1_).RemoveDuplicates Columns:=1, Header:=xlNo
    Me.Sort.Apply
    Cells(1).Select
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub элемент_таблицы()
    Dim myRange As Range, myCell As Range, AL As Object, v As Variant, r As Variant, _
    myElement As Variant, i As Long, smyRange As Range, ssmyRange As Range
    Dim LastRow
    Dim sLastRow
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    LastRow = Sheets("Лист2").Cells(Sheets("Лист2").Rows.Count, 1).End(xlUp).Row
    sLastRow = Sheets("Лист3").Cells(Sheets("Лист3").Rows.Count, 1).End(xlUp).Row
    Set myRange = Sheets("Лист2").Range("A2:A" & LastRow)
    Set ssmyRange = Sheets("Лист3").Range("A2:A" & sLastRow)
    On Error Resume Next
    
    Set AL = CreateObject("system.Collections.Arraylist")

    For Each r In Array(myRange, ssmyRange)
        For Each v In r.Value
            If Not IsEmpty(v) And Not AL.contains(v) Then AL.Add v
    Next v, r
    AL.Sort

    On Error GoTo 0
    [проба!J2].Resize(, AL.Count) = AL.toarray
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub