如何根据表3的身份证号唯一值从表1、表2中提取人员信息到另一个表

qinhuan66

求助：如何根据表3的身份证号（唯一值）从表1、表2中提取人员到生成报表中。
1、按表3身份证号为主，从表1表2中提取相应的人员信息到生成报表。
2、以表3身份证号为主，凡表3中的人员在表1或表2只F列只为优秀G列为空白的就提取到生成报表的E列。
3、相反以表3身份证号为主，凡表3中的人员在表1或表2任何一张表G列出现《是》字的就提取到生成报表的C列。并求出人数
谢谢
以本图为例

求助.rar (14.28 KB, 下载次数: 11)

2017-12-27 15:06 上传

点击文件名下载附件

qinhuan66

连续3年优秀评一次三等功，即2014年、2015年、2016年都为优秀的人员。（如果2014年或2015年任何一年得过一次三等功，那2016只能得嘉奖）

qinhuan66

继续关注一下

qinhuan66

在线等待结果

jiminyanyan

都高级了，不会字典么…………

qinhuan66

jiminyanyan 发表于 2017-12-27 20:52
都高级了，不会字典么…………

让老师见笑了

jsgj2023

楼主可能另外一个领域成为了大师!

qinhuan66

jsgj2023 发表于 2017-12-27 21:05
楼主可能另外一个领域成为了大师!

谢谢我只是比较爱好Excel而已

chxw68

1. Sub test()
   
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 d = CreateObject("scripting.dictionary")
   
8.   For Each ws In Worksheets(Array("表1", "表2"))
   
9.     With ws
   
10.       r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
11.       arr = .Range("a4:g" & r)
    
12.       For i = 1 To UBound(arr)
    
13.         If arr(i, 6) = "优秀" And arr(i, 7) = "" Then
    
14.           xm = CStr(arr(i, 5))
    
15.           If Not d1.exists(xm) Then
    
16.             Set d1(xm) = CreateObject("scripting.dictionary")
    
17.           End If
    
18.           d1(xm)(ws.Name) = ""
    
19.         End If
    
20.       Next
    
21.     End With
    
22.   Next
    
23.   For Each aa In d1.keys
    
24.     If d1(aa).Count = 1 Then
    
25.       d1.Remove (aa)
    
26.     End If
    
27.   Next
    
28.   With Worksheets("表3")
    
29.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
30.     arr = .Range("a4:f" & r)
    
31.     m = 0
    
32.     For i = 1 To UBound(arr)
    
33.       If Not d.exists(arr(i, 2)) Then
    
34.         m = m + 1
    
35.         ReDim brr(1 To 7)
    
36.         brr(1) = m
    
37.         brr(2) = arr(i, 2)
    
38.       Else
    
39.         brr = d(arr(i, 2))
    
40.       End If
    
41.       xm = arr(i, 5)
    
42.       If d1.exists(xm) Then
    
43.         brr(5) = brr(5) & "," & arr(i, 3)
    
44.         brr(6) = brr(6) + 1
    
45.       Else
    
46.         brr(3) = brr(3) & "," & arr(i, 3)
    
47.         brr(4) = brr(4) + 1
    
48.       End If
    
49.       d(arr(i, 2)) = brr
    
50.     Next
    
51.   End With
    
52.   With Worksheets("生成报表")
    
53.     .UsedRange.Offset(5, 0).Clear
    
54.     m = 5
    
55.     For Each aa In d.keys
    
56.       brr = d(aa)
    
57.       If Len(brr(3)) <> 0 Then
    
58.         brr(3) = Mid(brr(3), 2)
    
59.       End If
    
60.       If Len(brr(5)) <> 0 Then
    
61.         brr(5) = Mid(brr(5), 2)
    
62.       End If
    
63.       m = m + 1
    
64.       .Cells(m, 1).Resize(1, 7) = brr
    
65.     Next
    
66.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
67.     .Range("a4:g" & r).Borders.LineStyle = xlContinuous
    
68.     .Range("c6:c" & r & ",e6:e" & r).WrapText = True
    
69.     .Rows("6:" & r).AutoFit
    
70.   End With
    
71. End Sub
    

复制代码

chxw68

这个题目开始还把人难住了，看了楼主2楼的说明才搞明白。