根据条件，从两个表中提取数据进行组合

cqxingchen

各位老师，需要实现目的，都写着“提取”表中，能否帮忙写一份VBA代码，万分感谢！

smuuwl

看起来很简单，但看文字难理解你的逻辑，你千言万语写那么多条件，不如模拟一个结果。

cqxingchen

不好意思，把结果写在表中了。附件重新上传

ykcbf1100

附件供参考。。。
稍有点复杂，有字典提取，有从身份证号提取性别、出生日期、年龄，还有合并单元格

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.1
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("编制")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 5)
   
6.     End With
   
7.     For i = 6 To UBound(arr)
   
8.         s = arr(i, 2)
   
9.         d(s) = Array(arr(i, 3), arr(i, 4), arr(i, 5))
   
10.     Next
    
11.     With Sheets("信息")
    
12.         r = .Cells(Rows.Count, 1).End(3).Row
    
13.         arr = .[a1].Resize(r, 9)
    
14.     End With
    
15.     ReDim brr(1 To r, 1 To 14)
    
16.     For i = 7 To UBound(arr)
    
17.         If arr(i, 9) = "副校级" Then
    
18.             m = m + 1
    
19.             brr(m, 1) = m
    
20.             brr(m, 2) = arr(i, 2)
    
21.             s = brr(m, 2)
    
22.             brr(m, 3) = d(s)(0)
    
23.             brr(m, 4) = d(s)(1)
    
24.             brr(m, 5) = d(s)(2)
    
25.             brr(m, 6) = arr(i, 3)
    
26.             If arr(i, 3) = "超设" Then
    
27.                 brr(m, 6) = arr(i, 8)
    
28.                 brr(m, 7) = arr(i, 3)
    
29.             End If
    
30.             If arr(i, 3) = "其他" Then
    
31.                 brr(m, 6) = ""
    
32.                 brr(m, 7) = arr(i, 3)
    
33.             End If
    
34.             brr(m, 8) = arr(i, 4)
    
35.             sfz = CStr(arr(i, 5))
    
36.             gender = Int(Mid(sfz, 17, 1))
    
37.             brr(m, 9) = IIf(gender = 1, "男", "女")
    
38.             brr(m, 10) = DateSerial(Mid(sfz, 7, 4), Mid(sfz, 11, 2), Mid(sfz, 13, 2))
    
39.             brr(m, 11) = DateDiff("yyyy", brr(m, 10), Date)
    
40.             brr(m, 12) = arr(i, 7)
    
41.             brr(m, 13) = arr(i, 8)
    
42.         End If
    
43.     Next
    
44.     With Sheets("提取")
    
45.         .[a6:n1000].Clear
    
46.         .Columns(5).WrapText = True
    
47.         With .[a6].Resize(m, 14)
    
48.             .Value = brr
    
49.             .Borders.LineStyle = 1
    
50.             .HorizontalAlignment = xlCenter
    
51.             .VerticalAlignment = xlCenter
    
52.         End With
    
53.         zr = Array(3, 4, 5)
    
54.         hb 6, 2, 3, zr
    
55.     End With
    
56. End Sub

复制代码

ykcbf1100

回复附件在审批中。。。

cqxingchen

ykcbf1100 发表于 2024-9-1 19:04
附件供参考。。。
稍有点复杂，有字典提取，有从身份证号提取性别、出生日期、年龄，还有合并单元格

非常感谢老师的辛苦解答。合并的时候，是否可以修改为根据学校名称来合并C、D、E列呢。

ykcbf1100

cqxingchen 发表于 2024-9-1 21:31
非常感谢老师的辛苦解答。合并的时候，是否可以修改为根据学校名称来合并C、D、E列呢。

这样吗？     

yanglinzi

请测试。。

cqxingchen

ykcbf1100 发表于 2024-9-1 22:08
这样吗？

感谢老师，就是这样，谢谢。