|
- Sub test1()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(1, .Columns.Count).End(xlToLeft).Column
- arr = .Range("a1").Resize(r, c)
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 1)) Then
- m = 1
- ReDim brr(1 To 4, 1 To m)
- Else
- brr = d(arr(i, 1))
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To 4, 1 To m)
- End If
- For j = 1 To 3
- brr(j, m) = arr(i, j)
- Next
- brr(4, m) = arr(i, 26)
- d(arr(i, 1)) = brr
- Next
- End With
- For Each aa In d.keys
- brr = d(aa)
- ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
- For i = 1 To UBound(brr)
- For j = 1 To UBound(brr, 2)
- crr(j, i) = brr(i, j)
- Next
- Next
- On Error Resume Next
- Set ws = Worksheets(aa & "班")
- If Err Then
- Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
- ws.Name = aa & "班"
- End If
- On Error GoTo 0
- With ws
- .Cells.Clear
- With .Range("a1")
- .Value = "2019-1期末考场安排汇总"
- With .Font
- .Size = 16
- .Name = "微软雅黑"
- End With
- .Resize(1, 4).Merge
- End With
- .Range("a2:d2") = Array("行政班", "学号", "姓名", "各科考场汇总")
- With .Range("a3").Resize(UBound(crr), UBound(crr, 2))
- .Value = crr
- .Borders.LineStyle = xlContinuous
- With .Font
- .Size = 10
- .Name = "微软雅黑"
- End With
- End With
- .Columns("a:f").AutoFit
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- Next
- End Sub
复制代码 |
|