|
|
Sub test1() '测试吧，写这个真不易……
Dim set_, data, results, target As Range
Dim ar, br(1 To 160, 1 To 80), cr, dict(1) As Object
Dim i As Long, j As Long, p As Long, x As Long, y As Long
Dim posRow As Long, posCol As Long, rowSize As Long, colSize As Long, iStep As Long
Sheet3.Activate
Cells.Clear
Application.ScreenUpdating = False
For j = LBound(dict) To UBound(dict)
Set dict(j) = CreateObject("Scripting.Dictionary")
Next
ar = Split("分数 排名 划线分 差值")
iStep = UBound(ar) + 1
br(1, 1) = "班别"
br(2, 1) = "排序"
br(2, 2) = "姓名"
For i = 4 To UBound(br)
br(i, 1) = i - 3
Next
set_ = Sheet1.Range("A1").CurrentRegion.Value
For i = 3 To UBound(set_)
dict(0).Add set_(i, 1), i 'Array(i, Split(set_(i, 2), "—"))
Next
rowSize = 3
colSize = 3
For j = 3 To UBound(set_, 2)
dict(0).Add set_(2, j), j
br(rowSize - 1, colSize) = set_(2, j)
dict(1).Add br(2, colSize), colSize
For i = 0 To UBound(ar)
br(rowSize, colSize + i) = ar(i)
Next
colSize = colSize + iStep
Next
colSize = colSize - 1
With Sheet2
data = .Range("A1", .Range("A1").CurrentRegion.Offset(1)).Value
End With
QuickSort data, 2, UBound(data) - 1, 1, UBound(data, 2), 2, False '班级名为 数字 形式
p = 1
Set target = Range("A2")
For i = 2 To UBound(data) - 1
If data(i, 2) <> data(i + 1, 2) Then
results = br
results(1, 2) = data(i, 2)
posRow = dict(0)(data(i, 2))
cr = Split(set_(posRow, 2), "—")
For x = 3 To UBound(set_, 2)
posCol = dict(1)(set_(2, x)) + 2
For y = 1 To cr(1) - cr(0) + 1
results(y + rowSize, posCol) = set_(posRow, x)
Next
Next
QuickSort data, p + 1, i, 1, UBound(data, 2), UBound(data, 2) - 1, True
If p + cr(0) < i + 1 Then
For y = p + cr(0) To p + cr(1)
rowSize = rowSize + 1
results(rowSize, 2) = data(y, 4)
For x = 6 To UBound(data, 2) Step 2
posCol = dict(1)(data(1, x))
For j = 0 To 1
results(rowSize, posCol + j) = data(y, x + j)
Next
If Len(data(y, x)) Then
If Len(results(rowSize, posCol + j)) Then _
results(rowSize, posCol + 3) = data(y, x) - results(rowSize, posCol + j)
Else
results(rowSize, posCol + j) = ""
End If
Next
If data(y, 2) <> data(y + 1, 2) Then Exit For
Next
End If
p = i
With target
.Resize(rowSize, colSize).Value = results
.Offset(1).Resize(2).Merge
.Offset(1, 1).Resize(2).Merge
With .CurrentRegion
Intersect(.Offset(0), .Offset(1)).Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Rows("1:3").Font.Bold = True
.Font.Name = "宋体"
End With
For j = 3 To colSize Step iStep
.Offset(1, j - 1).Resize(, iStep).HorizontalAlignment = xlCenterAcrossSelection
Next
End With
Set target = Cells(Rows.Count, "A").End(xlUp).Offset(2)
rowSize = 3
End If
Next
Set target = Nothing
For j = LBound(dict) To UBound(dict)
Set dict(j) = Nothing
Next
Application.ScreenUpdating = True
Beep
End Sub
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, j 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 While t < d
If ar(t, pCol) > pivot Then t = t + 1 Else Exit Do
Loop
Do While b > u
If ar(b, pCol) < pivot Then b = b - 1 Else Exit Do
Loop
Else 'Order by number ASC
Do While t < d
If ar(t, pCol) < pivot Then t = t + 1 Else Exit Do
Loop
Do While b > u
If ar(b, pCol) > pivot Then b = b - 1 Else Exit Do
Loop
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
'Do While t < d
' If (ar(t, pCol) > pivot) Xor Flag Then t = t + 1 Else Exit Do
'Loop
'Do While b > u
' If (ar(b, pCol) < pivot) Xor Flag Then b = b - 1 Else Exit Do
'Loop |
|
楼主: 候鸟之细雨言寺
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-3-26 15:21
