VBA根据身份证号从一个工作簿中的多个表里提取相应信息

高书兵 · 发表于 2023-4-13 09:25

不同的数据，在不同的表中，根据不同的工作需求，需要从不同的表中，提取信息，组成新表。组表时，在“工作表”中根据数据源表中的标题内容，在“工作表”中填写、提取数据后，再根据新表要求，修改标题。比如学历，有时候需要填写全日制学历，有时候需要填写最高学历（在职后进修的学历）。且新表的标题不确定，有时候是10项内容，有时候是15项内容。需要遍历“工作表标题”，再根据身份证号提取对应的数据。谢谢！！！

chxw68 · 发表于 2023-4-13 10:04

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim ws As Worksheet
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Worksheets("工作表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
brr = .Range("a1").Resize(r, c)
For i = 2 To UBound(brr)
d1(brr(i, 1)) = i
Next
For j = 2 To UBound(brr, 2)
d2(brr(1, j)) = j
Next
End With
For Each ws In Worksheets
If ws.Name <> "工作表" Then
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
If r > 1 Then
arr = .Range("a1").Resize(r, c)
For i = 2 To UBound(arr)
If d1.exists(arr(i, 1)) Then
m = d1(arr(i, 1))
For j = 2 To UBound(arr, 2)
If d2.exists(arr(1, j)) Then
n = d2(arr(1, j))
brr(m, n) = arr(i, j)
End If
Next
End If
Next
End If
End With
End If
Next
With Worksheets("工作表")
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2023-4-13 10:04

详见附件。

全党 · 发表于 2023-4-13 16:33

参与一下，不是太明白楼主的表述。

mmwwdd · 发表于 2023-4-13 17:14

洋务德雷 · 发表于 2023-4-13 17:28

是个不错的例子，但是描述不详细。基本信息还算可以，如果想做的完美一些，加我好友后详细沟通吧。

grf1973 · 发表于 2023-4-14 10:06

其实用数据库是很容易操作的。前提是各表表头/数据要规范，另外要生成的新表表头和各表表头要一致。

高书兵 · 发表于 2023-4-14 21:14

chxw68 发表于 2023-4-13 10:04
详见附件。

经测试，有的人性别提取不出来。

chxw68 · 发表于 2023-4-14 21:31

高书兵发表于 2023-4-14 21:14
经测试，有的人性别提取不出来。

附件中的性别全部提取过来了。

高书兵 · 发表于 2023-4-14 22:15

本帖最后由高书兵于 2023-4-14 22:19 编辑

chxw68 发表于 2023-4-14 21:31
附件中的性别全部提取过来了。

我在实际表中有497条数据，有99条没有提取出来性别，找到原因了

		自动登录	找回密码
密码			免费注册

[求助] VBA根据身份证号从一个工作簿中的多个表里提取相应信息

评分