多分、以下の内容で検索できます
Public UID As String Public TgRow As Long Public TgCol As Long Private Sub LDAPserch() ' Dim strLDAP As String Dim oLDAP As Object Dim mail As String Dim sei As String Dim mei As String Dim name As String Dim sei1 As String Dim mei1 As String Dim name1 As String Dim unit As String Dim corp As String Dim findNo As Integer Dim eUnit As String ' ↓↓ここからUID検索機能。UID検索機能から必要データを取得する ↓↓ On Error Resume Next If UID <> "" Then strLDAP = "LDAP://ldap.smile.sexy.co.jp/uid=" & _ UID & ",ou=people,o=sexy-group" 'LDAPへログオン Set oLDAP = GetObject(strLDAP) '入力されたUIDをセット mail = oLDAP.get("mail") 'メールアドレスの取得 sei = oLDAP.get("sn") '日本語 姓の取得 mei = oLDAP.get("givenName") '日本語 名の取得 name = oLDAP.get("cn") '日本語 姓名の取得 sei1 = oLDAP.get("sn;lang-en-phonetic") '英語 姓の取得 mei1 = oLDAP.get("givenName;lang-en-phonetic") '英語 名の取得 name1 = oLDAP.get("cn;lang-en-phonetic") '英語 姓名の取得 corp = oLDAP.get("o") '会社名の取得 unit = oLDAP.get("ou") '日本語 所属部署名の取得 Cells(TgRow, TgCol + 2).Formula = mail 'メールアドレスから findNo = InStr(mail, "@") 'ドメイン名を省く If UID = Left(mail, findNo - 1) Then Cells(TgRow, TgCol + 1) = "" '別名登録なければメールは転送せずクリア Else Cells(TgRow, TgCol + 1).Formula = Left(mail, findNo - 1) '別名登録済なら別名をメールに転送 End If Cells(TgRow, TgCol + 3).Formula = sei '日本語の姓を転送 Cells(TgRow, TgCol + 4).Formula = mei '日本語の名を転送 Cells(TgRow, TgCol + 5).Formula = name '日本語の姓名を転送する 'UIDから別シートの「tableau」を抽出する Cells(TgRow, TgCol + 6).Formula = WorksheetFunction.VLookup(UID, Sheet4.Range("A:B"), 2, False) If sei <> "" Then If Cells(TgRow, TgCol + 6).Formula = "" Then Cells(TgRow, TgCol + 6).Formula = "non" End If End If Cells(TgRow, TgCol + 7).Formula = sei1 '英語の姓を転送する Cells(TgRow, TgCol + 8).Formula = mei1 '英語の名を転送する Cells(TgRow, TgCol + 9).Formula = name1 '英語の姓名を転送 Cells(TgRow, TgCol + 10).Formula = unit '日本語の所属部署を転送 '日本語部所から別シートの「英語部所名」を抽出する searchEunit unit, eUnit '関数"searchEunit"(英語部所名を部所階層をさかのぼりながらあてに行く)呼び出し Cells(TgRow, TgCol + 11).Formula = eUnit '英語会社名転送 Cells(TgRow, TgCol + 12).Formula = corp '会社名を転送 '日本語会社名から別シートの「英語会社名」を抽出する Cells(TgRow, TgCol + 13).Formula = WorksheetFunction.VLookup(corp, Worksheets("会社リスト").Range("A:B"), 2, False) ''''''Cells(TgRow, TgCol + 13).Formula =WorksheetFunction.VLookup(corp, Sheet5.Range("A:B"), 2, False)'''''''' If Cells(TgRow, 4).Formula <> "" And Cells(TgRow, 14).Formula <> "" _ And Cells(TgRow, TgCol + 16).Formula <> "" And Cells(TgRow, 2).Formula = "" Then Cells(TgRow, 2).Formula = "依頼" End If End If Exit Sub End Sub Sub searchEunit(unit, eUnit) On Error Resume Next eUnit = WorksheetFunction.VLookup(unit, Worksheets("部所リスト").Range("A:B"), 2, False) While eUnit = "" And unit Like "* *" unit = Left(unit, InStrRev(unit, " ") - 1) eUnit = WorksheetFunction.VLookup(unit, Worksheets("部所リスト").Range("A:B"), 2, False) Wend End Sub Private Sub Worksheet_Change(ByVal Target As Range) 'UID新規入力を監視 '入力されたら重複チェックし、LDAPの登録情報を取得する Select Case Target.Column Case 3 '3列目を対象とする TgRow = Target.Row TgCol = Target.Column If Not Intersect(Cells(TgRow, TgCol), Target) Is Nothing Then '3列目に文字入力を監視 For x = 1 To Selection.Count If Cells(TgRow, TgCol) <> "" Then '更新行を見つけた Range(Cells(TgRow, TgCol + 1), Cells(TgRow, TgCol + 13)).ClearContents 'UID消されたらクリア With Worksheets("Sheet1") wLastGyou = .UsedRange.Rows.Count '最終行番号を取得 wCellVal = .Cells(TgRow, TgCol).Value 'セルの値を取得する If Application.CountIf(.Range("C3:C" & wLastGyou), wCellVal) > 1 Then 'C列(ID)に重複チェック '入力されたUIDが重複ならばメッセージ。 MsgBox "IDが重複しています。" & vbCrLf & "登録行へ移動します", vbOKOnly + vbInformation, "登録済!" Cells.Find(What:=wCellVal, LookIn:=xlValues, LookAt:=xlWhole).Activate '該当行へジャンプ Range(Cells(TgRow, TgCol), Cells(TgRow, TgCol + 13)).ClearContents '追加入力値もクリア Exit Sub End If End With UID = Cells(TgRow, TgCol).Value '入力値を検索対象へ Call LDAPserch '検索機能実行 Else UID = "" 'UIDを削除されたら Range(Cells(TgRow, TgCol + 1), Cells(TgRow, TgCol + 13)).ClearContents '行クリア End If TgRow = TgRow + 1 Next End If End Select End Sub