|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("全校计划")
- r = .Cells(.Rows.Count, 3).End(xlUp).Row
- arr = .Range("b5:e" & r)
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
- End If
- d(arr(i, 2))(arr(i, 4)) = Empty
- Next
- End With
- ReDim brr(1 To d.Count, 1 To 8)
- m = 0
- For Each aa In d.keys
- m = m + 1
- brr(m, 1) = m
- brr(m, 2) = aa
- brr(m, 3) = aa
- brr(m, 4) = Left(aa, 1)
- brr(m, 8) = Join(d(aa).keys, ",")
- Next
- With Worksheets("老师组名单")
- .Range("b5:k" & .Rows.Count).ClearContents
- .Range("b5").Resize(UBound(brr), UBound(brr, 2)) = brr
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|