如何根据各年度考核结果生成目标表12

yzyyyyyyy

如何根据各年度考核结果生成目标表12.rar (2.86 KB, 下载次数: 13)

2017-1-4 09:02 上传

点击文件名下载附件

各年度考核工作表：姓名，结果。实际中有多个年度，样表中仅列举了3年。年度根据工作表名。
目标表1：自动生成各年度考核工作表中所有出现过的姓名，各年度考核统计结果，及标题如2013、2014、2015
目标表2：已知姓名（指定姓名），指定年度（2013、2014、2015）的考核统计结果。

鄂龙蒙

用多表动态汇总就行了。

yeminqiang

看起来特麻烦........

microyip

鄂龙蒙 发表于 2017-1-4 10:09
用多表动态汇总就行了。

这个案例不是跟你的案例一样？

CC例例

写了1个,目标表2原理基本相同,楼主可以参照编写.

1. Sub 考核表1()
   
2.     Dim d As Object, Sht As Worksheet, arA, arB(1 To 1000, 1 To 11), x%, y%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     [a1].CurrentRegion.Offset(1).ClearContents
   
5.     For x = 9 To 11
   
6.         d(CStr(Cells(1, x))) = x
   
7.     Next
   
8.     For Each Sht In Worksheets
   
9.         If Sht.Name <> "目标表1" And Sht.Name <> "目标表2" Then
   
10.             arA = Sht.UsedRange
    
11.             For x = 2 To UBound(arA)
    
12.                 If Not d.Exists(arA(x, 1)) Then
    
13.                     y = y + 1
    
14.                     d(arA(x, 1)) = y
    
15.                     arB(y, 1) = arA(x, 1)
    
16.                 End If
    
17.                 arB(d(arA(x, 1)), 2) = arB(d(arA(x, 1)), 2) + 1
    
18.                 arB(d(arA(x, 1)), 3) = IIf(arB(d(arA(x, 1)), 3) = "", _
    
19.                 Sht.Name, arB(d(arA(x, 1)), 3) & "," & Sht.Name)
    
20.                 If d.Exists(Sht.Name) Then arB(d(arA(x, 1)), d(Sht.Name)) = arA(x, 2)
    
21.                 Select Case arA(x, 2)
    
22.                     Case "优秀"
    
23.                         arB(d(arA(x, 1)), 4) = arB(d(arA(x, 1)), 4) + 1
    
24.                         arB(d(arA(x, 1)), 5) = IIf(arB(d(arA(x, 1)), 5) = "", _
    
25.                         Sht.Name, arB(d(arA(x, 1)), 5) & "," & Sht.Name)
    
26.                     Case "合格"
    
27.                         arB(d(arA(x, 1)), 6) = arB(d(arA(x, 1)), 6) + 1
    
28.                         arB(d(arA(x, 1)), 7) = IIf(arB(d(arA(x, 1)), 7) = "", _
    
29.                         Sht.Name, arB(d(arA(x, 1)), 7) & "," & Sht.Name)
    
30.                 End Select
    
31.             Next
    
32.         End If
    
33.     Next
    
34.     [a2].Resize(y, 11) = arB
    
35. End Sub

复制代码

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim ws As Worksheet
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   n = 8
   
9.   For Each ws In Worksheets
   
10.     If ws.Name Like "201#" Then
    
11.       n = n + 1
    
12.       d1(ws.Name) = n
    
13.     End If
    
14.   Next
    
15.   For Each ws In Worksheets
    
16.     If ws.Name Like "201#" Then
    
17.       With ws
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         arr = .Range("a2:b" & r)
    
20.         For i = 1 To UBound(arr)
    
21.           If Not d.exists(arr(i, 1)) Then
    
22.             ReDim brr(1 To n)
    
23.             brr(1) = arr(i, 1)
    
24.             brr(3) = ws.Name
    
25.           Else
    
26.             brr = d(arr(i, 1))
    
27.             brr(3) = brr(3) & "," & ws.Name
    
28.           End If
    
29.           brr(2) = brr(2) + 1
    
30.           If arr(i, 2) = "优秀" Then
    
31.             brr(4) = brr(4) + 1
    
32.             If Len(brr(5)) = 0 Then
    
33.               brr(5) = ws.Name
    
34.             Else
    
35.               brr(5) = brr(5) & "," & ws.Name
    
36.             End If
    
37.           ElseIf arr(i, 2) = "合格" Then
    
38.             brr(6) = brr(6) + 1
    
39.             If Len(brr(7)) = 0 Then
    
40.               brr(7) = ws.Name
    
41.             Else
    
42.               brr(7) = brr(7) & "," & ws.Name
    
43.             End If
    
44.           End If
    
45.           brr(d1(ws.Name)) = arr(i, 2)
    
46.           d(arr(i, 1)) = brr
    
47.         Next
    
48.       End With
    
49.     End If
    
50.   Next
    
51.   With Worksheets("目标表1")
    
52.     .UsedRange.Offset(1, 0).Clear
    
53.     .Range("c:c,e:e,g:g").NumberFormatLocal = "@"
    
54.     .Range("a2").Resize(d.Count, n) = Application.Transpose(Application.Transpose(d.items))
    
55.   End With
    
56. End Sub
    

复制代码

chxw68

详见附件。

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Set d2 = CreateObject("scripting.dictionary")
   
8.   With Worksheets("目标表2")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
11.     .Range("b2").Resize(r - 1, c - 1).ClearContents
    
12.     arr = .Range("a1").Resize(r, c)
    
13.     For i = 2 To UBound(arr)
    
14.       d1(arr(i, 1)) = i
    
15.     Next
    
16.   End With
    
17.   For Each ws In Worksheets
    
18.     d2(ws.Name) = ""
    
19.   Next
    
20.   For j = 9 To UBound(arr, 2)
    
21.     If d2.exists(CStr(arr(1, j))) Then
    
22.       With Worksheets(CStr(arr(1, j)))
    
23.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.         brr = .Range("a2:b" & r)
    
25.         For i = 1 To UBound(brr)
    
26.           If d1.exists(brr(i, 1)) Then
    
27.             m = d1(brr(i, 1))
    
28.             arr(m, 2) = arr(m, 2) + 1
    
29.             If Len(arr(m, 3)) = 0 Then
    
30.               arr(m, 3) = arr(1, j)
    
31.             Else
    
32.               arr(m, 3) = arr(m, 3) & "," & arr(1, j)
    
33.             End If
    
34.             If brr(i, 2) = "优秀" Then
    
35.               arr(m, 4) = arr(m, 4) + 1
    
36.               If Len(arr(m, 5)) = 0 Then
    
37.                 arr(m, 5) = arr(1, j)
    
38.               Else
    
39.                 arr(m, 5) = arr(m, 5) & "," & arr(1, j)
    
40.               End If
    
41.             End If
    
42.             If brr(i, 2) = "合格" Then
    
43.               arr(m, 6) = arr(m, 6) + 1
    
44.               If Len(arr(m, 7)) = 0 Then
    
45.                 arr(m, 7) = arr(1, j)
    
46.               Else
    
47.                 arr(m, 7) = arr(m, 7) & "," & arr(1, j)
    
48.               End If
    
49.             End If
    
50.             arr(m, j) = brr(i, 2)
    
51.           End If
    
52.         Next
    
53.       End With
    
54.     End If
    
55.   Next
    
56.   With Worksheets("目标表2")
    
57.     .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
58.   End With
    
59. End Sub
    

复制代码

chxw68

详见附件。

鄂龙蒙

microyip 发表于 2017-1-4 14:00
这个案例不是跟你的案例一样？

是的老师，边学边帮他做的，碰到了问题，感谢您的帮助，让学生又学到了新知识，请老师审阅。谢谢！
多表动态汇总.rar (14.53 KB, 下载次数: 8)

2017-1-4 15:39 上传

点击文件名下载附件