|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test3()
- Dim r%, i%
- Dim arr, brr, zrr(), fsd() As Variant
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- Set d3 = CreateObject("scripting.dictionary")
- Call main
- With Worksheets("录入成绩")
- r = .Cells(.Rows.Count, 4).End(xlUp).Row
- arr = .Range("a2:n" & r)
- End With
-
- For j = 5 To UBound(arr, 2) - 1
- If Application.Count(Application.Index(arr, 0, j)) > 0 Then
- Set d(arr(1, j)) = CreateObject("scripting.dictionary")
- fsd = dcs(arr(1, j))("分数段")
- ReDim Preserve fsd(1 To UBound(fsd) + 1)
- fsd(UBound(fsd)) = dcs(arr(1, j))("满分")
- ls = 2 + UBound(fsd) * 2 + 3
- For i = 2 To UBound(arr)
- If Len(arr(i, j)) <> 0 Then
- If Not d(arr(1, j)).exists(arr(i, 2)) Then
- ReDim brr(1 To ls)
- brr(1) = arr(i, 2)
- brr(2) = arr(1, j)
- Else
- brr = d(arr(1, j))(arr(i, 2))
- End If
- brr(3) = brr(3) + 1
- If IsEmpty(brr(4)) Then
- brr(4) = arr(i, j)
- Else
- If brr(4) < arr(i, j) Then
- brr(4) = arr(i, j)
- End If
- End If
- If IsEmpty(brr(5)) Then
- brr(5) = arr(i, j)
- Else
- If brr(5) > arr(i, j) Then
- brr(5) = arr(i, j)
- End If
- End If
- n = Application.Match(arr(i, j), fsd)
- If Not IsError(n) Then
- n = UBound(fsd) - n + 6
- brr(n) = brr(n) + 1
- End If
- End If
- d(arr(1, j))(arr(i, 2)) = brr
- Next
- End If
- Next
- m = 1
- With Worksheets("分数段A")
- .Cells.Clear
- For Each aa In d.keys
- .Cells(m, 1).Resize(1, 5) = Array("年级", "科目", "实考" & vbLf & "人数", "最高" & vbLf & "分", "最低" & vbLf & "分")
- n = 6
- fsd = dcs(aa)("分数段")
- ReDim Preserve fsd(1 To UBound(fsd) + 1)
- fsd(UBound(fsd)) = dcs(aa)("满分")
- ls = 5 + UBound(fsd) * 2
- For j = UBound(fsd) To 1 Step -1
- If j = UBound(fsd) Then
- .Cells(m, n) = ">=" & vbLf & fsd(j)
- Else
- .Cells(m, n) = "(" & fsd(j + 1) & "," & vbLf & fsd(j) & "]"
- End If
- n = n + 1
- Next
- For j = UBound(fsd) To 1 Step -1
- .Cells(m, n) = fsd(j) & "分" & vbLf & "以上"
- n = n + 1
- Next
- ReDim crr(1 To d(aa).Count, 1 To ls)
- ReDim drr(1 To ls)
- x = 0
- For Each bb In d(aa).keys
- brr = d(aa)(bb)
- x = x + 1
- For j = 1 To UBound(brr)
- crr(x, j) = brr(j)
- Next
- For j = 1 To UBound(fsd)
- If j = 1 Then
- crr(x, 5 + UBound(fsd) + j) = crr(x, j + 5)
- Else
- crr(x, 5 + UBound(fsd) + j) = crr(x, 5 + UBound(fsd) + j - 1) + crr(x, j + 5)
- End If
- Next
- Next
- drr(1) = "小计"
- drr(2) = aa
- drr(3) = Application.Sum(Application.Index(crr, 0, 3))
- drr(4) = Application.Max(Application.Index(crr, 0, 4))
- drr(5) = Application.Min(Application.Index(crr, 0, 5))
- For j = 6 To UBound(crr, 2)
- drr(j) = Application.Sum(Application.Index(crr, 0, j))
- Next
-
- .Cells(m + 1, 1).Resize(1, UBound(drr)) = drr
- .Cells(m + 2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
- .Rows(m).RowHeight = 28
- .Rows(m + 1).Resize(UBound(crr) + 2).RowHeight = 15
- With .Cells(m, 1).Resize(UBound(crr) + 2, UBound(crr, 2))
- .Borders.LineStyle = xlContinuous
- .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
- With .Font
- .Size = 10
- End With
- End With
- With .Cells(m, 5 + UBound(fsd)).Resize(UBound(crr) + 2, 1).Borders(xlEdgeRight)
- .LineStyle = xlContinuous
- .Weight = xlMedium
- End With
- m = m + UBound(crr) + 3
- Next
- .Columns.AutoFit
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|