end0tknr's kipple - web写経開発

太宰府天満宮の狛犬って、妙にカワイイ

excel vba で ldap検索

多分、以下の内容で検索できます

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