根据Excel姓名和身份证号从文本文件提取相关数据到指定列

APPLE123

可否根据Excel文件中的姓名和身份证号从文本文件提取相关数据到Excel指定列

1、将Excel文件中的姓名和身份证号与文本文件的姓名和身份证号核对，一致则从文本文件中提取所属单位证书编号和所属单位名称到Excel文件的D、E列对应的单元格，如D3：E4

2、测试文本2.txt有很多人员信息，由系统导出，主要包括人员姓名、身份证号、所属单位证书编号、所属单位名称、手机号、技术职称、是否就职等，但是有一小部分人员未填写手机号或技术职称，当前文本提供12个人仅是样本。

3、测试文本2.txt的人员信息，姓名、身份证号、所属单位证书编号、所属单位名称和是否就职属于必填项目，手机号和技术职称属于选填项目。选填项目可能没有填写，测试文本2.txt就会跳过。2个“就职”之间就是一条完整的记录。

希望VBA一键获取D、E的内容（底色为绿色的单元格），可否实现，请老师们帮帮忙，谢谢！

shiruiqiang

软件或网页数据库导出，应该可以选择excel的

APPLE123

shiruiqiang 发表于 2024-12-4 20:25
软件或网页数据库导出，应该可以选择excel的

谢谢老师关注！由于系统比较老旧，无法选择Excel，只能手工黏贴成Excel的

ykcbf1100

有坑，表中B列和C列的单元格中居然都有回车符，清洗过数据以后才会得到想要的结果。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.4
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     f = p & "测试文本2.txt"
   
7.     Open f For Input As #1
   
8.     zrr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
   
9.     Close #1
   
10.     For i = 0 To UBound(zrr)
    
11.         If InStr(zrr(i), "就职") Then k = k + 1: d1(k) = i
    
12.     Next
    
13.     On Error Resume Next
    
14.     For k = 1 To d1.Count
    
15.         r1 = d1(k)
    
16.         s = zrr(r1 + 1) & "|" & zrr(r1 + 2)
    
17.         d(s) = Array(zrr(r1 + 3), zrr(r1 + 4))
    
18.     Next
    
19.     r = Cells(Rows.Count, 1).End(3).Row
    
20.     arr = [a1].Resize(r, 8)
    
21.     For i = 3 To UBound(arr)
    
22.         s = arr(i, 2) & "|" & arr(i, 3)
    
23.         If d.exists(s) Then
    
24.        '     t = d(s)
    
25.             arr(i, 4) = d(s)(0)
    
26.             arr(i, 5) = d(s)(1)
    
27.         End If
    
28.     Next
    
29.     Columns(4).NumberFormatLocal = "@"
    
30.     [a1].Resize(r, 8) = arr
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    

复制代码

APPLE123

ykcbf1100 发表于 2024-12-4 21:06
参与一下。。。

谢谢老师，正是这样子的。

APPLE123

ykcbf1100 发表于 2024-12-4 21:06
参与一下。。。

麻烦老师帮忙一下，zrr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)这句代码是什么意思？谢谢！

另外，清洗数据统一格式，可否使用代码？谢谢！

ykcbf1100

APPLE123 发表于 2024-12-5 07:53
麻烦老师帮忙一下，zrr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)这句代码是什么意思？谢 ...

就是导入文本文件的意思。
如果就去除回车符，可用trim函数吧。

ykcbf1100

代码简化一下，再加上清洗BC列单元格回车符清洗代码。

ykcbf1100

代码简化一下。

1. Sub ykcbf()   '//2024.12.5
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = p & "测试文本2.txt"
   
6.     Open f For Input As #1
   
7.     zrr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
   
8.     Close #1
   
9.      On Error Resume Next
   
10.     For i = 0 To UBound(zrr)
    
11.         If InStr(zrr(i), "就职") Then
    
12.             r1 = i
    
13.             s = zrr(r1 + 1) & "|" & zrr(r1 + 2)
    
14.             d(s) = Array(zrr(r1 + 3), zrr(r1 + 4))
    
15.             i = i + 4
    
16.         End If
    
17.     Next
    
18.     r = Cells(Rows.Count, 1).End(3).Row
    
19.     arr = [a1].Resize(r, 8)
    
20.     For i = 3 To UBound(arr)
    
21.         s = Replace(arr(i, 2), Chr(13), "") & "|" & Replace(arr(i, 3), Chr(13), "")
    
22.         If d.exists(s) Then
    
23.             arr(i, 4) = d(s)(0)
    
24.             arr(i, 5) = d(s)(1)
    
25.         End If
    
26.     Next
    
27.     Columns(4).NumberFormatLocal = "@"
    
28.     [a1].Resize(r, 8) = arr
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码