I modified the code slightly, but not too different. It's working on 500 rows and 17 columns. Can you try this.

And here's the code.

Code:
Sub ExcelFox()
        
    Dim lng As Long
    Dim wks As Worksheet
    Dim objDic As Object
    Dim var As Variant
    Dim varIndex As Variant
    Dim lngRow As Long
    Const clngLastColumn As Long = 17
    Const clngSteps As Long = 100000
    
    Set objDic = CreateObject("Scripting.Dictionary")
    Set wks = Worksheets("NameOfSheetWithDuplicateValues")
    For lng = 1 To clngLastColumn
        With wks
            .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
            var = .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).Value2
            For lngRow = 1 To UBound(var)
                objDic.Item(var(lngRow, 1)) = 0
            Next lngRow
        End With
    Next lng
    Erase var
    var = objDic.keys
    var = Application.Transpose(Application.Transpose(var))
    Set objDic = Nothing
    If wks.Parent.FullName <> wks.Parent.Name Then
        wks.Parent.Save
    End If
    lng = 1
    For lngRow = 1 To UBound(var) + Abs(LBound(var) = 0) Step clngSteps
        varIndex = Application.Transpose(Evaluate(clngSteps * (lng - 1) & "+ ROW(1:" & Application.Min(UBound(var) + Abs(LBound(var) = 0), clngSteps) & ")"))
        Cells(1, clngLastColumn + lng).Resize(Application.Min(UBound(var) + Abs(LBound(var) = 0), clngSteps)).Value2 = Application.Transpose(Application.Index(var, varIndex))
        lng = lng + 1
    Next lngRow
    Erase varIndex
    
End Sub