Remove Duplicates From Across Multipe Columns In A Single WorkSheet

[Admin]

Resulted with column A with 1mln rows and B with 143k rows. Ends with values starting with 'z' so seems to be working, yet I still can't find certain values from main table.

I'm sure you'll have some ideas.

Thank you.

Again I missed the last row part. In my test I hard coded last row as 100000. Give this a try.

Option Explicit

Sub kTest()
    
    Dim strAll  As String
    Dim i       As Long
    Dim r       As Long
    Dim n       As Long
    Dim d       As Long
    Dim fd      As String
    Dim fn      As String
    Dim objFS   As Object
    Dim objFile As Object
    Dim adoConn As Object
    Dim adoRset As Object
    
    Const Block = 65000
    
    strAll = "Temp"
    
    For i = 1 To 17
        d = 0
        n = Cells(Rows.Count, i).End(3).Row
        If n = 1 Then n = Rows.Count
        For r = 1 To n Step Block
            strAll = strAll & vbCrLf & Join(Application.Transpose(Cells(r, i).Resize(Application.Min(Block, Abs(n - d))).Value2), vbCrLf)
            d = d + Block
        Next
    Next
    
    fd = Environ("temp") & "\"
    fn = "Test.txt"
    
    Set objFS = CreateObject("scripting.filesystemobject")
    Set objFile = objFS.opentextfile(fd & fn, 2, 1)
    
    objFile.write strAll
    objFile.Close
    
    Set adoConn = CreateObject("ADODB.Connection")
    
    adoConn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
                "Dbq=" & fd & ";Extensions=txt;"
        
    Set adoRset = CreateObject("ADODB.Recordset")
        adoRset.Open "SELECT [Temp] FROM [" & fn & "] GROUP BY [Temp]", adoConn, 3, 1, 1
            
    d = adoRset.RecordCount
    
    ActiveSheet.UsedRange.ClearContents
    
    If d > Rows.Count Then
        i = 1
        While Not adoRset.EOF
            Cells(1, i).CopyFromRecordset adoRset, 1000000
            i = i + 1
        Wend
    Else
        Range("a1").CopyFromRecordset adoRset
    End If
    
    adoRset.Close
    adoConn.Close
    
    Kill fd & fn
    
End Sub