Sub TestSortRange()
Dim toRng As Range
Set toRng = Selection
If toRng.Rows.Count > 1 And toRng.Columns.Count > 1 Then Set toRng = toRng.Columns(1)
Call SortRange(toRng, regPattern:=".", regReplace:="a", regSet:=68, sortSet:=2)
End Sub
' Сортировка ячеек в диапазоне inputRange
' regPattern - шаблон регулярного выражения применяемого к подстрокам перед сортировкой. если не задан сортировка ведется по значениям подстрок
' regReplace - строка регулярного выражения для замены
' regSet - флаги регулярного выражения (по умолчанию 0):
' младший бит: если 0 возвращаемый результат соответствует шаблону, 1 - из подстроки удаляется соответствие шаблону
' второй бит:
' третий бит: если 0 поиск до первого совпадения, 1 - поиск по всему тексту
' четвертый бит: если 0 учитывать регистр, 1 - не учитывать регистр
' пятый бит: если 0 текст однострочный, 1 - многострочный текст
' шестой бит:
' седьмой бит: если 1 используется серия замен в строке inputString вместо регулярного выражения:
' строка regPattern задает набор искомых строк разделенных разделителем withDelimit,
' строка regReplace набор строк замены с разделителем withDelimit соответствующий порядку строк regPattern
' третий и четвертый биты имеют такое же значение как для регулярного выражения
' восьмой бит: если 1 сортировка подстрок в строке inputString производится по индексам в строке regPattern заданным через разделитель withDelimit
' все остальные биты в regSet и другие флаги не имеют значения
' sortSet - флаги сортировки (по умолчанию 0):
' младший бит: если 1 сортировка по убыванию
' второй бит: если 1 использовать натуральное сравнение
Sub SortRange(inputRange As Variant, Optional regPattern As String = "", Optional regReplace As String = "", _
Optional regSet As Byte = 0, Optional sortSet As Byte = 0, Optional withDelimit As String = " ")
Dim arrStr() As Variant, arrBuff() As String, s As String, arrFind() As String, arrRep() As String
Dim arrIdx() As Long, i As Long, n As Long, r As Long, j As Long
Dim regEx As Object, regItems As Object, rItem As Object, inRng As Range, tmpRng As Range
Dim theWS As Worksheet, tmpWS As Worksheet, tmpWB As Workbook
Dim fScreen As Boolean
fScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
If IsObject(inputRange) Then Set inRng = inputRange Else Set inRng = Range(inputRange)
Set theWS = inRng.Worksheet
Set tmpWB = Workbooks.Add(xlWBATWorksheet)
Set tmpWS = tmpWB.Sheets(1)
Set tmpRng = tmpWS.Range(inRng.Address)
inRng.Copy
tmpRng.PasteSpecial
arrStr = Application.Transpose(inRng.Value)
On Error Resume Next
n = UBound(arrStr, 2)
If n > 0 Then arrStr = Application.Transpose(arrStr)
n = UBound(arrStr)
If regPattern = "" Then
arrIdx = SortArrIdx(arrStr, IIf(sortSet And 1, 1, 0) + IIf(sortSet And 2, 2, 0) + 16)
ElseIf regSet And 128 Then
arrBuff = Split(regPattern, withDelimit)
If UBound(arrBuff) < n Then ReDim Preserve arrBuff(0 To n)
ReDim arrIdx(0 To n)
For i = 1 To n
If arrBuff(i) > "" Then If IsNumeric(arrBuff(i)) Then If CLng(arrBuff(i)) <= n And CLng(arrBuff(i)) > 0 Then arrIdx(i) = arrStr(CLng(arrBuff(i)))
Next i
Else
If regSet And 64 Then
arrFind = Split(regPattern, withDelimit)
arrRep = Split(regReplace, withDelimit)
r = UBound(arrFind)
If UBound(arrRep) < r Then ReDim Preserve arrRep(0 To r)
Else
Set regEx = CreateObject("VBScript.RegExp")
If regSet And 4 Then regEx.Global = True Else regEx.Global = False
If regSet And 8 Then regEx.IgnoreCase = True Else regEx.IgnoreCase = False
If regSet And 16 Then regEx.MultiLine = True Else regEx.MultiLine = False
regEx.Pattern = regPattern
End If
ReDim arrBuff(0 To n)
For i = 0 To n
If regSet And 64 Then
arrBuff(i) = arrStr(i)
For j = 0 To r
arrBuff(i) = Replace(arrBuff(i), arrFind(j), arrRep(j), 1, IIf(regSet And 4, -1, 1), IIf(regSet And 8, vbTextCompare, vbBinaryCompare))
Next j
Else
If regEx.Test(arrStr(i)) Then
If regSet And 4 Then
Set regItems = regEx.Execute(arrStr(i))
s = ""
For Each rItem In regItems
s = s & rItem
Next rItem
Else
s = regEx.Execute(arrStr(i)).Item(0)
End If
If regSet And 1 Then arrBuff(i) = regEx.Replace(arrStr(i), regReplace) Else arrBuff(i) = IIf(regReplace = "", s, regEx.Replace(s, regReplace))
Else
If regSet And 1 Then arrBuff(i) = arrStr(i) Else arrBuff(i) = ""
End If
End If
Next i
arrIdx = SortArrIdx(arrBuff, 16 + IIf(sortSet And 1, 1, 0) + IIf(sortSet And 2, 2, 0))
End If
For i = 1 To n
tmpRng.Cells(arrIdx(i)).Copy
inRng.Cells(i).PasteSpecial
Next
tmpWB.Close SaveChanges:=False
Application.ScreenUpdating = fScreen
End Sub
' keySet значения:
' младший бит: 0 - сортировка по возрастанию, 1 - сортировка по убыванию
' второй бит: если 1 использовать натуральное сравнение
' пятый бит: если 1 вернуть индексы исходных подстрок в отсортированном порядке
Function SortArrIdx(ByVal Arr, Optional keySet As Byte = 0)
Dim i&, j&, n&, l&, tmp, tt, arrIdx() As Long
If Not IsArray(Arr) Then SortArrIdx = Arr: Exit Function
n = UBound(Arr)
l = LBound(Arr)
ReDim arrIdx(l To n)
For i = l To n
arrIdx(i) = i
Next i
If n > 0 Then
If keySet And 1 Then
For i = n To 1 Step -1
For j = i - 1 To l Step -1
If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
Else
If keySet And 2 Then
If CompareNaturale(Arr(i), Arr(j)) = 1 Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
Else
If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
End If
End If
Next j, i
Else
For i = l To n - 1
For j = i + 1 To n
If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
Else
If keySet And 2 Then
If CompareNaturale(Arr(i), Arr(j)) = 1 Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
Else
If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
End If
End If
Next j, i
End If
End If
If keySet And 16 Then SortArrIdx = arrIdx Else SortArrIdx = Arr
End Function
' функция натурального сравнения, возвращает номер большего аргумента либо 0 в случае равенства
' при сравнении чисел в строках учитывается знак минус, знак точки и региональный знак точки (запятая)
Function CompareNaturale(ByVal str1 As String, ByVal str2 As String) As Integer
Dim i, k, k1, k2 As Long
Dim s1(), s2(), dsep As String
Dim v1, v2 As Variant
Dim nn As Boolean
If str1 = str2 Then
CompareNaturale = 0
Else
If str1 Like "*#*" And str2 Like "*#*" Then
dsep = Application.International(xlDecimalSeparator)
k1 = 1
ReDim Preserve s1(0 To k1)
If IsNumeric(Left(str1, 1)) Then nn = True Else nn = False
For i = 1 To Len(str1)
If IsNumeric(Mid(str1, i, 1)) Then
If Not nn Then
k1 = k1 + 1
ReDim Preserve s1(0 To k1)
nn = True
If LTrim(Right(s1(k1 - 1), 2)) = "-" And Not (IsNumeric(s1(k1 - 2)) And Len(s1(k1 - 1)) = 1) Then
s1(k1 - 1) = Left(s1(k1 - 1), Len(s1(k1 - 1)) - 1)
s1(k1) = "-"
End If
End If
Else
If nn Then
k1 = k1 + 1
ReDim Preserve s1(0 To k1)
nn = False
End If
End If
s1(k1) = s1(k1) & Mid(str1, i, 1)
Next i
k2 = 1
ReDim Preserve s2(0 To k2)
If IsNumeric(Left(str2, 1)) Then nn = True Else nn = False
For i = 1 To Len(str2)
If IsNumeric(Mid(str2, i, 1)) Then
If Not nn Then
k2 = k2 + 1
ReDim Preserve s2(0 To k2)
nn = True
If LTrim(Right(s2(k2 - 1), 2)) = "-" And Not (IsNumeric(s2(k2 - 2)) And Len(s2(k2 - 1)) = 1) Then
s2(k2 - 1) = Left(s2(k2 - 1), Len(s2(k2 - 1)) - 1)
s2(k2) = "-"
End If
End If
Else
If nn Then
k2 = k2 + 1
ReDim Preserve s2(0 To k2)
nn = False
End If
End If
s2(k2) = s2(k2) & Mid(str2, i, 1)
Next i
k = IIf(k1 < k2, k1, k2)
For i = 1 To k
If s1(i) <> s2(i) Then
If IsNumeric(s1(i)) And IsNumeric(s2(i)) Then
v1 = CLng(s1(i))
v2 = CLng(s2(i))
If i > 1 Then
If Replace(Trim(s1(i - 1)), ".", dsep) = dsep Then
v1 = CDbl("0" & dsep & s1(i))
If i > 2 Then If IsNumeric(s1(i - 2)) Then If CLng(s1(i - 2)) < 0 Then v1 = 0 - v1
End If
If Replace(Trim(s2(i - 1)), ".", dsep) = dsep Then
v2 = CDbl("0" & dsep & s2(i))
If i > 2 Then If IsNumeric(s2(i - 2)) Then If CLng(s2(i - 2)) < 0 Then v2 = 0 - v2
End If
End If
If v1 <> v2 Then
If v1 > v2 Then CompareNaturale = 1 Else CompareNaturale = 2
Else
If s1(i) > s2(i) Then CompareNaturale = 1 Else CompareNaturale = 2
End If
Else
If s1(i) > s2(i) Then CompareNaturale = 1 Else CompareNaturale = 2
End If
Exit For
Else
If i = k Then
If k1 = k2 Then CompareNaturale = 0 Else If k1 > k2 Then CompareNaturale = 1 Else CompareNaturale = 2
End If
End If
Next i
Else
If str1 > str2 Then CompareNaturale = 1 Else CompareNaturale = 2
End If
End If
End Function |
