Option Explicit
Const cnt = 65536
Sub SortRangeAL()
'---------------------------------------------------------------------------------------
' Procedure : SortRangeAL
' Author    : krosav4ig
' Date      : 27.10.2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
        'Dim ALS As New ArrayList, ALN As New ArrayList, ALD As New ArrayList, AL1 As New ArrayList 'mscorlib.tlb
        Dim ALS, ALN, ALD, AL1
10    Set ALS = CreateObject("System.Collections.ArrayList")
20    Set ALN = CreateObject("System.Collections.ArrayList")
30    Set AL1 = CreateObject("System.Collections.ArrayList")
40    Set ALD = CreateObject("System.Collections.ArrayList")
        Dim Lists(2)

        Dim Rng As Range, cell As Range
        Dim i%, n&, j%, k&, m&
        'Dim t#, t1#, t2#, t3#

50    On Error GoTo SortRange_Error
60    Set Rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.[A:A])
70    Rng.Offset(, 1).Clear
80    With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With
        't = timer
90    For Each cell In Rng
100       If Len(cell.Value) Then
110           If IsNumeric(cell.Value) Then
120               ALN.Add cell.Value
130           ElseIf IsDate(cell.Value) Then
140               ALD.Add cell.Value
150           Else
160               ALS.Add cell.Value
170           End If
180       End If
190   Next
        't1 = timer - t: t2 = timer
200   ALS.Sort: ALD.Sort: ALN.Sort
        't2 = timer - t2: t3 = timer
210   Set Lists(0) = ALD: Set Lists(1) = ALN: Set Lists(2) = ALS
220   For j = 0 To 2
230       i = 0
240       If Lists(j).Count Then
250           k = k + IIf(j, Lists(j + (j > 0)).Count, 0)
260           Do
270               n = Application.Min(cnt, Lists(j).Count - i * cnt)
280               Set AL1 = Lists(j).getrange(i * cnt - IIf(i, 1, 0), n)
290               With Rng(1).Offset(k + i * cnt, 1).Resize(n)
300                   .Formula = Application.Transpose(AL1.Toarray)
310                   If j = 0 Then
320                       .Replace ".", "/" '<--- шо-то тут не то
330                   End If
340                   m = .Count
350               End With
360               i = i + 1
370           Loop While n = cnt And i < 16
380       End If
390   Next
        't3 = timer - t3: t = timer - t
        'MsgBox "Запись значений в ArrayList - " & t1 & Chr(10) & "Непосредственно сортировка - " & t2 & Chr(10) & _
               "Вывод в диапазон - " & t3 & Chr(10) & "Итого - " & t
400   Erase Lists: Set ALS = Nothing: Set ALN = ALS: Set AL1 = ALS

SortRange_Error:
410   With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With
420   If Err.Number Then MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub SortRangeAL on line " & Erl
End Sub