跨表自动记录输入并查找提示【zhaogang1960老师赐教下解决】

lisan

如附件，身份证号输入.xls的sheet!A1输入身份证号，希望达到以下效果：
1、在人员信息.xls的sheet!A列自动记录每次输入的身份证号码。（若需要处于打开状态，可事先打开人员信息.xls）
2、自动在人员信息.xls的Agent Info表中（人员很多，附件予以简化）查找（H、J、L、N、P、R列）是否存在以上每次输入的身份证号。
若不存在，则在人员信息.xls的sheet!B列提示“不存在”。
若存在，则在人员信息.xls的sheet!B列显示该身份证号对应的姓名及其对应D列的姓名及关系（本人、父亲、母亲、夫妻、子女一、子女二）。
如：在身份证号输入.xls的sheet!A1输入230500400126071，则在人员信息.xls的sheet!A1记录230500400126071，并在人员信息.xls的sheet!B1显示 孙玉学 - 孙艳（父亲）。
烦请高手予以赐教。谢谢！
问题.rar (2.67 KB, 下载次数: 13)

2011-1-4 17:42 上传

点击文件名下载附件

[ 本帖最后由 lisan 于 2011-1-4 20:30 编辑 ]

lisan

问题应该说得很清楚呀。顶上去再求赐教。

zhaogang1960

试试看：
问题.rar (11.3 KB, 下载次数: 36)

2011-1-4 19:17 上传

点击文件名下载附件

lisan

我的神啊！谢谢！
我的意思是能显示 孙玉学 - 孙艳（父亲），烦请zhaogang1960 老师再修改一下。
另弱弱的问一句，VBA代码一定要写在身份证号输入.xls上吗？能不能写在人员信息.xls？

zhaogang1960

原帖由 lisan 于 2011-1-4 19:26 发表
我的神啊！谢谢！
我的意思是能显示 孙玉学 - 孙艳（父亲），烦请zhaogang1960 老师再修改一下。
另弱弱的问一句，VBA代码一定要写在身份证号输入.xls上吗？能不能写在人员信息.xls？

不能写在人员信息.xls，因为触发程序的动作是在身份证号输入.xls上发出的
问题.rar (14.73 KB, 下载次数: 39)

2011-1-4 19:55 上传

点击文件名下载附件

lisan

十分感谢zhaogang1960老师的赐教。
1、如果是本人，也希望按这种格式 孙艳 - 孙艳（本人）。
2、能否用什么方法，不要将VBA代码写在身份证号输入.xls上（身份证号输入.xls无法修改），又能解决问题？
3、在人员信息.xls sheet!A列的记录能不能不要直接保存（由使用者关闭时再决定是否保存）？
烦请zhaogang1960老师再赐教，谢谢！

[ 本帖最后由 lisan 于 2011-1-4 20:12 编辑 ]

zhaogang1960

原帖由 lisan 于 2011-1-4 20:07 发表
十分感谢zhaogang1960老师的赐教。
1、能否用什么方法，不要将VBA代码写在身份证号输入.xls上（身份证号输入.xls无法修改），又能解决问题？
2、在人员信息.xls sheet!A列的记录能不能不要直接保存（由使用者关闭时 ...

1、如果要在身份证号输入.xls上输入，那就得把vba写在上面，否则无法触发Worksheet_Change过程
2、把ThisWorkbook代码区中的Workbook_BeforeClose事件代码删除就可以了

lisan

如果是本人，也希望按这种格式 孙艳 - 孙艳（本人）。

zhaogang1960

原帖由 lisan 于 2011-1-4 20:20 发表
如果是本人，也希望按这种格式 孙艳 - 孙艳（本人）。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "A1" Then Exit Sub
    If Target = "" Then Exit Sub
    Dim wb As Workbook, c As Range, s$
    s = Target
    On Error Resume Next
    Application.ScreenUpdating = False
    Set wb = Workbooks("人员信息.xls")
    If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\人员信息.xls")
    wb.Sheets("Sheet1").[a65536].End(xlUp).Offset(1) = Target
    With wb.Sheets("Agent Info")
        Set c = .UsedRange.Offset(, 7).Find(s, , , xlWhole)
        If Not c Is Nothing Then
            If c.Column = 8 Then
                wb.Sheets("Sheet1").[a65536].End(xlUp).Offset(, 1) = c.Offset(, -3) & "-" & c.Offset(, -3) & "(本人)"
            Else
                wb.Sheets("Sheet1").[a65536].End(xlUp).Offset(, 1) = c.Offset(, -1) & "-" & .Cells(c.Row, 5) & "(" & Replace(.Cells(1, c.Column - 1), "姓名", "") & ")"
            End If
        Else
            wb.Sheets("Sheet1").[a65536].End(xlUp).Offset(, 1) = "不存在"
        End If
    End With
    Me.Activate
    Application.ScreenUpdating = True
End Sub

lisan

十分感谢zhaogang1960老师不厌其烦的赐教！问题解决！