|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test1() '纯个人练习
-
- Dim data, i As Long, j As Long, pos As Long, col As Long
-
- With Worksheets("1").Range("A1").CurrentRegion
- data = Range(.Cells(1), .Offset(1)).Value
- End With
-
- col = 3
- For j = 0 To 2
- col = col + 1
- data(1, col) = Split("组合2 名次 4选2总分")(j)
- Next
-
- For i = 2 To UBound(data) - 1
- For j = 4 To col
- data(i, j) = ""
- Next
- For j = 9 To 12
- If Val(data(i, j)) Then
- data(i, col) = Val(data(i, col)) + Val(data(i, j))
- data(i, 4) = data(i, 4) & Left(data(1, j), 1)
- End If
- Next
- Next
-
- pos = 1
- QuickSort data, pos + 1, UBound(data) - 1, 1, col, 4, False
- For i = pos + 1 To UBound(data) - 1
- If data(i, 4) <> data(i + 1, 4) Then
- QuickSort data, pos + 1, i, 1, col, col, True
- CustomRank data, pos + 1, i, 6, 5, False
- pos = i
- End If
- Next
-
- With Worksheets("2").Range("A1")
- .CurrentRegion.Clear 'Contents
- With .Resize(UBound(data) - 1, col)
- .Borders.LineStyle = xlContinuous
- .HorizontalAlignment = xlCenter
- .Font.Name = "宋体"
- .Font.Size = 12
- .Value = data
- End With
- End With
-
- Beep
- End Sub
- Function CustomRank(ar, upper As Long, lower As Long, src As Long, dst As Long, Optional CHI As Boolean = False)
- Dim i As Long, rank_ As Long
- rank_ = 1
- ar(upper, dst) = 1
- For i = upper + 1 To lower
- If Not CHI Then
- rank_ = rank_ + 1
- Else '(ChineseStyle)
- If ar(i, src) <> ar(i - 1, src) Then rank_ = rank_ + 1
- End If
- If ar(i, src) <> ar(i - 1, src) Then
- ar(i, dst) = rank_
- Else
- ar(i, dst) = ar(i - 1, dst)
- End If
- Next
- End Function
- Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pCol As Long, Optional Flag As Boolean = True)
- Dim t As Long, b As Long, x As Long, pivot, swap
- t = u
- b = d
- pivot = ar((u + d) \ 2, pCol)
- While t <= b
- If Flag Then 'Order by number DESC
- Do
- If ar(t, pCol) > pivot Then t = t + 1 Else Exit Do
- Loop While t < d
- Do
- If ar(b, pCol) < pivot Then b = b - 1 Else Exit Do
- Loop While b > u
- Else 'Order by text ASC
- Do
- If StrComp(ar(t, pCol), pivot, vbTextCompare) = -1 Then t = t + 1 Else Exit Do
- Loop While t < d 'vbTextCompare 1 vbBinaryCompare 0
- Do
- If StrComp(pivot, ar(b, pCol), vbTextCompare) = -1 Then b = b - 1 Else Exit Do
- Loop While b > u
- End If
- If t < b Then
- For x = l To r
- swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
- Next
- t = t + 1: b = b - 1
- Else
- If t = b Then t = t + 1: b = b - 1
- End If
- Wend
- If t < d Then QuickSort ar, t, d, l, r, pCol, Flag
- If b > u Then QuickSort ar, u, b, l, r, pCol, Flag
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|