Option Explicit
Const N = 1000000
Sub Сортировка_Более_Миллиона_Элементов()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim r As Range
Set r = sh.Range("A1:E34")
Dim ar1 As Variant
ar1 = r
Dim ar2 As Variant
ar2 = GetAr2(ar1)
SortArr ar2
ReDim ar1(1 To r.Rows.Count, 1 To r.Columns.Count)
FillAr1 ar1, ar2
OutAr1 ar1
End Sub
Sub OutAr1(arr As Variant)
Dim wb As Workbook
Dim sh As Worksheet
Set wb = Workbooks.Add(1)
Set sh = wb.Sheets(1)
sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Sub FillAr1(ar1 As Variant, ar2 As Variant)
Dim y As Long
Dim u As Long
Dim x As Integer
Dim h As Integer
u = 1
h = 1
For x = 1 To UBound(ar2, 2)
For y = 1 To UBound(ar2, 1)
ar1(u, h) = ar2(y, x)
u = u + 1
If u > UBound(ar1, 1) Then
u = 1
If h < UBound(ar1, 2) Then h = h + 1
End If
Next
Next
End Sub
Sub SortArr(ByRef arr As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add(1)
Dim sh As Worksheet
Set sh = wb.Sheets(1)
Dim x As Integer
With sh
For x = 1 To UBound(arr)
.Cells(1, x).Resize(N, 1) = arr(x)
Next
End With
Dim r1 As Range
Dim r2 As Range
Dim ar1 As Variant
Dim ar2 As Variant
Dim y As Long
Dim bExit As Boolean
Dim n2 As Long
Dim y2 As Long
'y = N / 2
Do
For x = 1 To UBound(arr)
With sh.Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(1, x).Resize(N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Cells(1, x).Resize(N): .Header = xlGuess: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
.Apply
End With
Next
With sh
bExit = True
For x = 1 To UBound(arr) - 1
If Not IsEmpty(.Cells(1, x + 1).Value) Then
y = 0
On Error Resume Next
y = WorksheetFunction.Match(.Cells(1, x + 1).Value, .Cells(1, x).Resize(N), 1)
On Error GoTo 0
y = y + 1
If y <= N Then
n2 = WorksheetFunction.CountA(.Cells(1, x + 1).Resize(N))
y2 = y + n2 - 1
If y2 > N Then y2 = N
Set r1 = .Range(.Cells(y, x), .Cells(y2, x))
Set r2 = .Cells(1, x + 1).Resize(r1.Rows.Count)
' r1.Select
' r2.Select
ar1 = r1
ar2 = r2
r1 = ar2
Erase ar2
r2 = ar1
Erase ar1
bExit = False
'Exit For
If r1.Rows.Count <> N Then
With sh.Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(1, x + 1).Resize(N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Cells(1, x + 1).Resize(N): .Header = xlGuess: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
.Apply
End With
End If
End If
End If
Next
End With
If bExit Then Exit Do
Loop
With sh
x = UBound(arr)
arr = .Range(.Cells(1, 1), .Cells(N, x))
End With
wb.Saved = True
wb.Close
End Sub
Function GetAr2(arr As Variant) As Variant
Dim y As Long
Dim x As Integer
y = UBound(arr, 1) * UBound(arr, 2) / N
y = y + 1
Dim ar3 As Variant
ReDim ar3(1 To N, 1 To 1)
Dim ar2 As Variant
ReDim ar2(1 To y)
For y = 1 To UBound(ar2)
ar2(y) = ar3
Next
Erase ar3
Dim u As Long
Dim h As Long
h = 1
u = 1
For x = 1 To UBound(arr, 2)
For y = 1 To UBound(arr, 1)
ar2(h)(u, 1) = arr(y, x)
u = u + 1
If u > N Then
u = 1
h = h + 1
End If
Next
Next
GetAr2 = ar2
End Function
|
