如何根据人名查询，并显示照片？

楼主
研究研究

Q: 如何根据人名查询，并显示照片？

A: 由于有合并单元格，所以有些代码不能优化

Sub 查询信息()
If Range("d24") = "" Then
MsgBox "开玩笑！没有身份证号"
Exit Sub
End If
Dim A As Long, S As String
S = Range("D24").Value
With Sheets("数据库")
A = WorksheetFunction.CountIf(.Range("AR:AR"), S)
If A = 0 Then
MsgBox "没找到以下身份证号码的信息" & vbCrLf & vbCrLf & " " & S
Exit Sub
Else
Application.EnableEvents = False
ActiveSheet.DrawingObjects.Select
Selection.Delete
Range("A1:U1").Select
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\logo.JPG")
Range("U5:U9").Select
f = Dir(ThisWorkbook.Path & "\员工照片\" & Range("D24").Value & ".jpg")
If Len(f) = 0 Then
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\员工照片\" & "无.jpg")
Else
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\员工照片\" & Range("D24").Value & ".jpg")
End If
Range("H19:U28").Select
f = Dir(ThisWorkbook.Path & "\身份证正面\" & Range("D24").Value & ".jpg")
If Len(f) = 0 Then
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\身份证正面\" & "无.jpg")
Else
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\身份证正面\" & Range("D24").Value & ".jpg")
End If
Range("H29:U38").Select
f = Dir(ThisWorkbook.Path & "\身份证反面\" & Range("D24").Value & ".jpg")
If Len(f) = 0 Then
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\身份证反面\" & "无.jpg")
Else
ActiveSheet.Pictures.Insert (ThisWorkbook.Path & "\身份证反面\" & Range("D24").Value & ".jpg")
End If
A = Application.WorksheetFunction.Match(S, .Range("AR:AR"), 0)
Range("J5") = .Range("A" & A)
Range("D5") = .Range("B" & A)
Range("R5") = .Range("C" & A)
Range("D6") = .Range("D" & A)
Range("J6 ") = .Range("E" & A)
Range("R6") = .Range("F" & A)
Range("D7") = .Range("G" & A)
Range("J7") = .Range("H" & A)
Range("R7") = .Range("I" & A)
Range("D8") = .Range("J" & A)
Range("J8") = .Range("K" & A)
Range("R8") = .Range("L" & A)
Range("D9") = .Range("M" & A)
Range("J9") = .Range("N" & A)
Range("R9") = .Range("O" & A)
Range("D10") = .Range("P" & A)
Range("J10") = .Range("Q" & A)
Range("R10") = .Range("R" & A)
Range("D11") = .Range("S" & A)
Range("S11") = .Range("T" & A)
Range("D12 ") = .Range("U" & A)
Range("J12") = .Range("V" & A)
Range("S12") = .Range("W" & A)
Range("D13") = .Range("X" & A)
Range("H13") = .Range("Y" & A)
Range("O13") = .Range("Z" & A)
Range("U13") = .Range("AA" & A)
Range("A16") = .Range("AB" & A)
Range("D16") = .Range("AC" & A)
Range("F16") = .Range("AD" & A)
Range("Q16") = .Range("AE" & A)
Range("T16") = .Range("AF" & A)
Range("A17") = .Range("AG" & A)
Range("D17") = .Range("AH" & A)
Range("F17") = .Range("AI" & A)
Range("Q17") = .Range("AJ" & A)
Range("T17") = .Range("AK" & A)
Range("A18") = .Range("AL" & A)
Range("D18") = .Range("AM" & A)
Range("F18") = .Range("AN" & A)
Range("Q18") = .Range("AO" & A)
Range("T18") = .Range("AP" & A)
Range("D21") = .Range("AQ" & A)
Range("D24") = .Range("AR" & A)
Range("D26") = .Range("AS" & A)
Range("D28") = .Range("AT" & A)
Application.EnableEvents = True
End If
End With
Range("a1").Select
End Sub

员工档案信息照片.rar

2楼
悠悠雨

人事可以用到噢