Remove Duplicates From Across Multipe Columns In A Single WorkSheet

[Admin]

Hi, only got another chance to get on it.

Unfortunately, same run-time error 14, out of string space.

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
    Dim Flg     As Boolean
    
    Const Block = 65000
    
    fd = Environ("temp") & "\"
    fn = "Test.txt"
    
    Set objFS = CreateObject("scripting.filesystemobject")
    
    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
        If Flg Then
            Set objFile = objFS.opentextfile(fd & fn, 8)
        Else
            Set objFile = objFS.opentextfile(fd & fn, 2, 0)
            Flg = True
        End If
        objFile.write strAll
        objFile.Close
        strAll = vbNullString
    Next
    If LenB(strAll) Then
        Set objFile = objFS.opentextfile(fd & fn, IIf(Flg, 8, 2), IIf(Flg, 0, 1))
        objFile.write strAll
        objFile.Close
    End If
    
    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