如何根据原始表中的姓名部门生成目标表12345

yzyyyyyyy

原始表：姓名，部门
目标表1：生成每个人员的所有部门，分别放入多个单元格中
目标表2：生成每个人员的所有部门，分别放入同一个单元格中，之间用逗号隔开
目标表3：生成每个人员在对应的部门打钩，说明部门为程序自动生成。
目标表4：生成每个人员在对应的部门打钩，说明部门为事先设定好。
统计表：生成所有部门人数，合计以及人员名单，分别放入多个单元格中 如何根据原始表中的姓名部门2列生成目标表1234及统计表.rar (2.99 KB, 下载次数: 19)

2017-11-22 10:30 上传

点击文件名下载附件

uynayna

楼主老师还是hr，一次出了这么多考题。

yzyyyyyyy

朱荣兴 发表于 2017-11-22 11:10

感谢版主热心帮助。怪我没说清楚，表3和表4是有不一样的要求。表3中B1：J1的部门、姓名均应由程序自动生成，表4中的姓名、B1：D1部门要事先手动录入。目前统计表中语文组数学组英语组物理组化学组德育组工会等部门，没有得到姓名列表。版主辛苦了。

chxw68

1. Sub test1() '目标表1
   
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, 1).End(xlUp).Row
   
8.     arr = .Range("a2:b" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.       m = 2
    
13.       ReDim brr(1 To m)
    
14.       brr(1) = arr(i, 1)
    
15.     Else
    
16.       brr = d(arr(i, 1))
    
17.       m = UBound(brr) + 1
    
18.       ReDim Preserve brr(1 To m)
    
19.     End If
    
20.     brr(m) = arr(i, 2)
    
21.     d(arr(i, 1)) = brr
    
22.   Next
    
23.   With Worksheets("目标表1")
    
24.     .Cells.Clear
    
25.     .Range("a1") = "姓名"
    
26.     m = 1
    
27.     ls = 0
    
28.     For Each aa In d.keys
    
29.       m = m + 1
    
30.       brr = d(aa)
    
31.       .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
32.       If ls < UBound(brr) Then
    
33.         ls = UBound(brr)
    
34.       End If
    
35.     Next
    
36.     For j = 2 To ls
    
37.       .Cells(1, j) = "部门" & j - 1
    
38.     Next
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

1. Sub test2() '目标表2
   
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, 1).End(xlUp).Row
   
8.     arr = .Range("a2:b" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.       m = 1
    
13.       ReDim brr(1 To m)
    
14.     Else
    
15.       brr = d(arr(i, 1))
    
16.       m = UBound(brr) + 1
    
17.       ReDim Preserve brr(1 To m)
    
18.     End If
    
19.     brr(m) = arr(i, 2)
    
20.     d(arr(i, 1)) = brr
    
21.   Next
    
22.   With Worksheets("目标表2")
    
23.     .Cells.Clear
    
24.     .Range("a1") = "姓名"
    
25.     .Range("b1") = "部门"
    
26.     m = 1
    
27.     For Each aa In d.keys
    
28.       m = m + 1
    
29.       brr = d(aa)
    
30.       .Cells(m, 1) = aa
    
31.       .Cells(m, 2) = Join(brr, ",")
    
32.     Next
    
33.   End With
    
34. End Sub
    
35. 
    

复制代码

chxw68

1. Sub test3() '目标表3
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   With Worksheets("原始表")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:b" & r)
   
10.   End With
    
11.   n = 1
    
12.   For i = 1 To UBound(arr)
    
13.     If Len(arr(i, 2)) <> 0 Then
    
14.       If Not d1.exists(arr(i, 2)) Then
    
15.         n = n + 1
    
16.         d1(arr(i, 2)) = n
    
17.       End If
    
18.     End If
    
19.   Next
    
20.   
    
21.   ls = d1.Count + 1
    
22.   For i = 1 To UBound(arr)
    
23.     If Not d.exists(arr(i, 1)) Then
    
24.       ReDim brr(1 To ls)
    
25.       brr(1) = arr(i, 1)
    
26.     Else
    
27.       brr = d(arr(i, 1))
    
28.     End If
    
29.     If d1.exists(arr(i, 2)) Then
    
30.       n = d1(arr(i, 2))
    
31.       brr(n) = "√"
    
32.     End If
    
33.     d(arr(i, 1)) = brr
    
34.   Next
    
35.   
    
36.   With Worksheets("目标表3")
    
37.     .Cells.Clear
    
38.     .Range("a1") = "姓名"
    
39.     .Range("b1").Resize(1, d1.Count) = d1.keys
    
40.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
41.   End With
    
42. End Sub

复制代码