Hi

Here is a different method.

Code:
Option Explicit

Sub kTest()
    
    Dim strAll  As String
    Dim i       As Long
    Dim r       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 = 32000
    
    strAll = "Temp"
    
    For i = 1 To 5
        d = 0
        For r = 1 To 100000 Step Block
            strAll = strAll & vbCrLf & Join(Application.Transpose(Cells(r, i).Resize(Application.Min(Block, Abs(100000 - 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