Sub PrepareForSort()
Dim arr(), arr0(), a&, aa, x&, dt$, b%
arr0 = Range("A6:A" & [A6].CurrentRegion.Rows.Count + 6).Value
For a = 1 To UBound(arr0)
If arr0(a, 1) > 0 Then x = x + 1
Next
ReDim arr(1 To x, 1 To 3): x = 1
For a = 1 To UBound(arr0)
If arr0(a, 1) > 0 Then
dt = Replace$(CStr(arr0(a, 1)), " ", "-"): b = 1
Do Until Mid$(dt, b, 1) Like "#": b = b + 1: Loop
If Mid$(dt, b - 1, 1) <> "-" Then dt = Left$(dt, b - 1) & "-" & Right$(dt, Len(dt) - b + 1)
aa = Split(dt, "-")
For b = 0 To UBound(aa): arr(x, b + 1) = aa(b): Next
If arr(x, 2) <> vbNullString Then arr(x, 2) = CDbl(Replace$(arr(x, 2), ".", ","))
x = x + 1
End If
Next
ArrSort arr(), 2: ArrSort arr(), 1
ReDim arr0(1 To UBound(arr), 1 To 1)
For a = 1 To UBound(arr)
If arr(a, 1) = "АМГ" Then
arr0(a, 1) = arr(a, 1) & " " & arr(a, 2) & "-" & arr(a, 3)
ElseIf arr(a, 3) <= 0 Then
arr0(a, 1) = arr(a, 1) & "-" & arr(a, 2)
Else: arr0(a, 1) = arr(a, 1) & "-" & arr(a, 2) & "-" & arr(a, 3)
End If
Next
[A6].Resize(UBound(arr), 1) = arr0
End Sub
'----------------
Sub ArrSort(mass(), ByVal n%)
Dim a&, b&, c&, i&, xx&, jj&, mm, x1&, x&
Dim arr&(), arr0&(), sArr()
If UBound(mass, 1) < 2 Then Exit Sub
ReDim arr(1 To UBound(mass, 1))
ReDim arr0(1 To UBound(mass, 1)): xx = 1
For i = 1 To UBound(mass, 1): arr(i) = i: Next
b = UBound(mass, 1)
jj = xx: arr0(xx) = arr(1)
For c = 2 To b
xx = xx + 1: x1 = xx
mm = mass(arr(c), n)
Do While mass(arr0(x1 - 1), n) > mm
arr0(x1) = arr0(x1 - 1): x1 = x1 - 1
If x1 = jj Then Exit Do
Loop
arr0(x1) = arr(c)
Next
ReDim sArr(1 To UBound(mass, 1), 1 To UBound(mass, 2))
For a = 1 To UBound(arr0)
For c = 1 To UBound(mass, 2)
sArr(a, c) = mass(arr0(a), c)
Next c
Next a: Erase arr: Erase arr0
mass = sArr: Erase sArr
End Sub |