Option Explicit
Sub test()
Dim arr, i, j, k, n, p, t
arr = Sheets("sheet1").UsedRange.Value
For i = 1 To UBound(arr, 1)
n = 2: p = n
ReDim brr(1 To UBound(arr, 2) + 1, 1 To 3)
For j = 3 To UBound(arr, 2)
If InStr(arr(i, j), ".") Then
n = n + 1: brr(n, 3) = arr(i, j)
arr(i, j) = Replace(arr(i, j), Space(1), vbNullString)
For k = Len(arr(i, j)) To 1 Step -1
If IsNumeric(Mid(arr(i, j), k, 1)) Then
t = Split(left(arr(i, j), k), ".")
brr(n, 1) = Val(t(0))
If UBound(t) > 0 Then brr(n, 2) = Val(t(1)) Else brr(n, 2) = 0
Exit For
End If
Next
End If
Next
Call bsort(brr, 3, n, 1, UBound(brr, 2), 1)
For j = 3 To n
If brr(j, 1) <> brr(j + 1, 1) Then
Call bsort(brr, p + 1, j, 1, UBound(brr, 2), 2)
p = j
End If
Next
For j = 3 To UBound(arr, 2)
If j > n Then arr(i, j) = vbNullString Else arr(i, j) = brr(j, 3)
Next
Next
Sheets("Sheet1 (2)").[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Function bsort(arr, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If arr(j, key) > arr(j + 1, key) Then
For k = left To right
t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
Next
End If
Next
Next
End Function |
楼主: On_fire
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2020-9-22 19:17
