|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test3()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- vs = [{"照顾对象",1,2,3;"特长生",3,8,1}]
- For k = 1 To UBound(vs)
- Set d(vs(k, 1)) = CreateObject("scripting.dictionary")
- Set d1(vs(k, 1)) = CreateObject("scripting.dictionary")
- With Worksheets(vs(k, 1))
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(1, .Columns.Count).End(xlToLeft).Column
- arr = .Range("a2").Resize(r - 1, c)
- n = 2
- For i = 1 To UBound(arr)
- If Not d1(vs(k, 1)).exists(arr(i, vs(k, 3))) Then
- n = n + 1
- d1(vs(k, 1))(arr(i, vs(k, 3))) = n
- End If
- Next
- ls = n
- For i = 1 To UBound(arr)
- If Not d(vs(k, 1)).exists(arr(i, vs(k, 2))) Then
- ReDim brr(1 To ls)
- brr(1) = arr(i, vs(k, 2))
- Else
- brr = d(vs(k, 1))(arr(i, vs(k, 2)))
- End If
- n = d1(vs(k, 1))(arr(i, vs(k, 3)))
- brr(n) = brr(n) + 1
- brr(2) = brr(2) + 1
- d(vs(k, 1))(arr(i, vs(k, 2))) = brr
- Next
- End With
- Next
- With Worksheets("统计表")
- .Cells.Clear
- r = 1
- For Each aa In d.keys
- .Cells(r, 1) = "班级"
- With .Cells(r, 3)
- .Value = aa
- .Resize(1, d(aa).Count).Merge
- End With
- .Cells(r + 1, 3).Resize(1, d1(aa).Count) = d1(aa).keys
- ReDim crr(1 To d(aa).Count, 1 To 2 + d1(aa).Count)
- ReDim drr(1 To 2 + d1(aa).Count)
- drr(1) = "合计"
- m = 0
- For Each bb In d(aa).keys
- brr = d(aa)(bb)
- m = m + 1
- For j = 1 To UBound(brr)
- crr(m, j) = brr(j)
- Next
- For j = 2 To UBound(brr)
- drr(j) = drr(j) + brr(j)
- Next
- Next
- .Cells(r + 2, 1).Resize(1, UBound(drr)) = drr
- .Cells(r + 3, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
- With .Cells(r, 1).Resize(3 + UBound(crr), UBound(crr, 2))
- .Borders.LineStyle = xlContinuous
- With .Font
- .Name = "微软雅黑"
- .Size = 10
- End With
- End With
- .Columns(1).Resize(, UBound(crr, 2)).AutoFit
- r = r + 2 + UBound(crr) + 3
- Next
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|