组成员提取

jx928867128

初.zip (31.44 KB, 下载次数: 2)

2021-8-12 21:35 上传

点击文件名下载附件

求好心人帮忙写个组成员自动提取代码

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("全校计划")
   
7.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
   
8.     arr = .Range("b5:e" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 2)) Then
    
11.         Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       d(arr(i, 2))(arr(i, 4)) = Empty
    
14.     Next
    
15.   End With
    
16.   ReDim brr(1 To d.Count, 1 To 8)
    
17.   m = 0
    
18.   For Each aa In d.keys
    
19.     m = m + 1
    
20.     brr(m, 1) = m
    
21.     brr(m, 2) = aa
    
22.     brr(m, 3) = aa
    
23.     brr(m, 4) = Left(aa, 1)
    
24.     brr(m, 8) = Join(d(aa).keys, ",")
    
25.   Next
    
26.   With Worksheets("老师组名单")
    
27.     .Range("b5:k" & .Rows.Count).ClearContents
    
28.     .Range("b5").Resize(UBound(brr), UBound(brr, 2)) = brr
    
29.   End With
    
30. End Sub
    

复制代码

chxw68

详见附件。

jx928867128

chxw68 发表于 2021-8-12 21:45

老师好，再次打扰您了，我有一贴关于课程表的代码，不知您方便帮我改下吗https://club.excelhome.net/thread-1656605-1-1.html