Option Explicit
Sub TEST4()
Dim ar, br, i&, n&, t#
Application.ScreenUpdating = False
t = Timer
With Sheets(1).[A1].CurrentRegion
ar = .Value
ReDim br(1 To UBound(ar), 1 To 2)
For i = 1 To UBound(ar)
br(i, 1) = i
n = 0
For j = 1 To UBound(ar, 2)
If Len(ar(i, j)) Then n = n + 1
Next j
br(i, 2) = n
Next i
Cells.Clear
bSort br, 1, UBound(br), 1, UBound(br, 2), 2, False
Cells.Clear
For i = 1 To UBound(br)
.Rows(br(i, 1)).Copy Cells(i, 1)
Next i
End With
Application.ScreenUpdating = True
MsgBox "执行完毕!_用时: " & Format(Timer - t, "0.00") & " 秒", 64
End Sub
Function bSort(ar, iFirst&, iLast&, iLeft&, iRight&, _
iKey&, Optional isOrder As Boolean = True)
Dim i&, j&, k&, vTemp
For i = iFirst To iLast - 1
For j = iFirst To iLast + iFirst - 1 - i
If ar(j, iKey) <> ar(j + 1, iKey) Then
If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
For k = iLeft To iRight
vTemp = ar(j, k): ar(j, k) = ar(j + 1, k): ar(j + 1, k) = vTemp
Next
End If
End If
Next j
Next i
End Function
|