'v2
Sub LongStringSort()
Dim rTarg As Range
Set rTarg = Selection
'Set rTarg = rTarg.Columns(1)
Set rTarg = Intersect(rTarg, rTarg.Parent.UsedRange)
Set rTarg = rTarg.Areas(1)
If rTarg.Cells.CountLarge = 1 Then Exit Sub
Dim rSort As Range
On Error Resume Next
Set rSort = Application.InputBox("Введите столбец сортировки", "Сортировка", rTarg.Columns(1).EntireColumn.Address(0, 0, xlA1), Type:=8)
On Error GoTo 0
If rSort Is Nothing Then Exit Sub
If Intersect(rSort, rTarg) Is Nothing Then Exit Sub
Dim xSort As Long
xSort = rSort.Column - rTarg.Column + 1
If xSort < 0 Then Exit Sub
Dim arr As Variant
arr = rTarg.Value
ClearArray arr
arr = GetSortArray(arr, xSort)
If IsEmpty(arr) Then Exit Sub
rTarg.Value = arr
End Sub
Private Function GetSortArray(arr As Variant, xSort As Long) As Variant
Dim sortBeg As Long
Dim sortFin As Long
Dim mrr As Variant
mrr = GetMultiColumnArray(arr, xSort, sortBeg, sortFin)
If IsEmpty(mrr) Then Exit Function
If sortBeg < 1 Then Exit Function
If sortFin < sortBeg Then Exit Function
With Workbooks.Add(1)
With .Sheets(1)
Dim rr As Range
Set rr = .Cells(1, 1).Resize(UBound(mrr, 1), UBound(mrr, 2))
rr.Value = mrr
With .Sort
.SortFields.Clear
Dim xr As Long
For xr = sortBeg To sortFin
.SortFields.Add Key:=rr.Columns(xr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Next
.SetRange rr
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
mrr = rr.Value
End With
.Close False
End With
Dim orr As Variant
orr = GetOneColumnArray(mrr, sortBeg, sortFin)
GetSortArray = orr
End Function
Private Function GetOneColumnArray(arr As Variant, sortBeg As Long, sortFin As Long) As Variant
Dim orr As Variant
ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - (sortFin - sortBeg))
Dim ya As Long
Dim xa As Long
Dim xo As Long
Dim ss As String
For ya = 1 To UBound(arr, 1)
For xa = 1 To sortBeg - 1
orr(ya, xa) = arr(ya, xa)
Next
xo = UBound(orr, 2)
For xa = UBound(arr, 2) To sortFin + 1 Step -1
orr(ya, xo) = arr(ya, xa)
xo = xo - 1
Next
ss = ""
For xa = sortBeg To sortFin
ss = ss & arr(ya, xa)
Next
orr(ya, sortBeg) = ss
Next
GetOneColumnArray = orr
End Function
Private Function GetMultiColumnArray(arr As Variant, xSort As Long, sortBeg As Long, sortFin As Long) As Variant
Const nStep = 255
Dim nx As Long
nx = GetColumnNumbers(arr, xSort, nStep)
If nx = 0 Then Exit Function
sortBeg = xSort
sortFin = sortBeg + nx - 1
Dim brr As Variant
ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + nx - 1)
Dim ss As String
Dim iPart As Long
Dim xb As Long
Dim xa As Long
Dim ya As Long
For ya = 1 To UBound(arr, 1)
For xb = 1 To xSort - 1
brr(ya, xb) = arr(ya, xb)
Next
xb = UBound(brr, 2)
For xa = UBound(arr, 2) To xSort + 1 Step -1
brr(ya, xb) = arr(ya, xa)
xb = xb - 1
Next
If arr(ya, xSort) <> "" Then
xb = xSort
iPart = 0
Do
ss = Mid(arr(ya, xSort), 1 + iPart * nStep, nStep)
If ss = "" Then Exit Do
brr(ya, xb) = ss
xb = xb + 1
iPart = iPart + 1
Loop
End If
Next
GetMultiColumnArray = brr
End Function
Private Function GetColumnNumbers(arr As Variant, xSort As Long, nn As Long) As Long
Dim ni As Long
Dim nMax As Long
Dim ya As Long
For ya = 1 To UBound(arr, 1)
If arr(ya, xSort) <> "" Then
ni = Len(arr(ya, xSort)) \ nn + 1
If nMax < ni Then nMax = ni
End If
Next
GetColumnNumbers = nMax
End Function
Private Sub ClearArray(arr As Variant)
Dim ya As Long
Dim xa As Long
For ya = LBound(arr, 1) To UBound(arr, 1)
For xa = LBound(arr, 2) To UBound(arr, 2)
If IsError(arr(ya, xa)) Then
arr(ya, xa) = Empty
End If
Next
Next
End Sub
|
