asked on

Active directory telehone no updating excel macro. Need a change.

Hi,

Active directory updating excel macro. Need a change.

What ever the code is doing now needs to be intact
except the telephone no change

I need the script to look at colum C. If
KT then update the data as 44-678
PJT then update the data as 44-679
Any other data in colum C then update the current one.

The main change is as locations change the suffix of the extension no (Telephone no) changes.
Thats the chjange i need

Any help is greatly useful.

Regards
Sharath

Sub Upd()
 
    Application.EnableEvents = False
    Const ADS_PROPERTY_CLEAR = 1
    For intRow = 2 To Cells(65536, "L").End(xlUp).Row
        strNTLogin = Trim(Cells(intRow, "L").Value)
        If strNTLogin <> "" Then
            strSeatNo = Trim(Cells(intRow, "B").Value)
            strBuilding = Trim(Cells(intRow, "C").Value)
            strSerialNo = Trim(Cells(intRow, "T").Value)
            strExt = Trim(Cells(intRow, "D").Value)
            strDepartment = Trim(Cells(intRow, "H").Value)
            strTitle = Trim(Cells(intRow, "J").Value)
            strMachine = Trim(Cells(intRow, "Q").Value)
            strManager = Trim(Cells(intRow, "BI").Value)
            strEmail = Trim(Cells(intRow, "O").Value)
            strEmpId = Trim(Cells(intRow, "E").Value)
            If strManager <> "" Then
                strManagerDN = Get_LDAP_User_Properties("user", "name", strManager, "distinguishedName")
            Else
                strManagerDN = ""
            End If
            If InStr(strManagerDN, "^") > 0 Then strManagerDN = Split(strManagerDN, "^")(1)
            strADsPath = Get_LDAP_User_Properties("user", "samAccountName", strNTLogin, "adsPath")
            If InStr(strADsPath, "^") > 0 Then strADsPath = Split(strADsPath, "^")(1)
            If InStr(strADsPath, "LDAP://") > 0 Then
                Set objUser = GetObject(strADsPath)
                boolChanged = False
                
                If UCase(objUser.physicalDeliveryOfficeName) <> UCase(strBuilding) Then
                    With Cells(intRow, "C").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strSeatNo <> "" Then
                        objUser.physicalDeliveryOfficeName = UCase(strBuilding)
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "physicalDeliveryOfficeName", 0
                    End If
                End If
                
                If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-391" & strExt & ")") Then
                    With Cells(intRow, "D").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strExt <> "" Then
                        objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-391" & strExt & ")")
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
                    End If
                End If
 
                If UCase(objUser.Department) <> UCase(strDepartment) Then
                    With Cells(intRow, "H").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strDepartment <> "" Then
                        objUser.Department = strDepartment
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "department", 0
                    End If
                End If
 
                If UCase(objUser.Title) <> UCase(strTitle) Then
                    With Cells(intRow, "J").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strTitle <> "" Then
                        objUser.Title = strTitle
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "title", 0
                    End If
                End If
                
                strNotesText = "EMP ID : " & strEmpId & vbCrLf & "EMAIL ADDRESS : " & strEmail & vbCrLf & "Machine Name : " & strMachine & vbCrLf & "Location : " & strSeatNo & vbCrLf & "Serial Number : " & strSerialNo
                If UCase(objUser.Info) <> UCase(strNotesText) Then
                    With Cells(intRow, "B").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    With Cells(intRow, "Q").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    With Cells(intRow, "T").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strMachine <> "" Then
                        objUser.Info = UCase(strNotesText)
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "info", 0
                    End If
                End If
                
                If InStr(strManagerDN, "CN=") > 0 Then
                    If objUser.Manager <> "" Then
                        If UCase(Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)) <> UCase(strManager) Then
                            With Cells(intRow, "BI").Interior
                                .ColorIndex = 36
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                            End With
                            boolChanged = True
                            objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
                            objUser.SetInfo
                            objUser.Manager = strManagerDN
                        End If
                    Else
                        With Cells(intRow, "BI").Interior
                            .ColorIndex = 36
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                        End With
                        boolChanged = True
                        objUser.Manager = strManagerDN
                    End If
                ElseIf objUser.Manager <> "" Then
                    ' Clear the Manager
                    With Cells(intRow, "BI").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
                End If
                
                If boolChanged = True Then
                    objUser.SetInfo
                End If
                Set objUser = Nothing
            End If
        End If
    Next
    Application.EnableEvents = True
End Sub
 
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
      
      If InStr(strObjectToGet, "\") > 0 Then
            arrGroupBits = Split(strObjectToGet, "\")
            strDC = arrGroupBits(0)
            strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
            strObjectToGet = arrGroupBits(1)
      Else
            Set objRootDSE = GetObject("LDAP://RootDSE")
            strDNSDomain = objRootDSE.Get("defaultNamingContext")
      End If
 
      strDetails = ""
      strBase = "<LDAP://" & strDNSDomain & ">"
      ' Setup ADO objects.
      Set adoCommand = CreateObject("ADODB.Command")
      Set adoConnection = CreateObject("ADODB.Connection")
      adoConnection.Provider = "ADsDSOObject"
      adoConnection.Open "Active Directory Provider"
      adoCommand.ActiveConnection = adoConnection
 
 
      ' Filter on user objects.
      'strFilter = "(&(objectCategory=person)(objectClass=user))"
      strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
 
      ' Comma delimited list of attribute values to retrieve.
      strAttributes = strCommaDelimProps
      arrProperties = Split(strCommaDelimProps, ",")
 
      ' Construct the LDAP syntax query.
      strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
      adoCommand.CommandText = strQuery
      adoCommand.Properties("Page Size") = 100
      adoCommand.Properties("Timeout") = 30
      adoCommand.Properties("Cache Results") = False
 
      ' Run the query.
      Set adoRecordset = adoCommand.Execute
      ' Enumerate the resulting recordset.
      Do Until adoRecordset.EOF
          ' Retrieve values and display.
          For intCount = LBound(arrProperties) To UBound(arrProperties)
                If strDetails = "" Then
                    If IsArray(adoRecordset.Fields(intCount)) = False Then
                      strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
                    Else
                      strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
                    End If
                Else
                    If IsArray(adoRecordset.Fields(intCount)) = False Then
                      strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
                    Else
                      strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
                    End If
                End If
          Next
          ' Move to the next record in the recordset.
          adoRecordset.MoveNext
      Loop
 
      ' Clean up.
      adoRecordset.Close
      adoConnection.Close
      Get_LDAP_User_Properties = strDetails
 
End Function

Open in new window

CSLARSEN

Hi
I assume the current describtion in column C has the KT or PJT or some other letters
If so, then insert this instead of line 9:

If Trim(Cells(intRow, "C").Value) = "KT" then
strBuilding = "44-678"
Else if
Trim(Cells(intRow, "C").Value) = "PJT" then
strBuilding = "44-679"
Else
strBuilding = Trim(Cells(intRow, "C").Value)
End if

NB I do not have excel with me here so code is not testet. Make sure to make backups before running code.
Cheers
cslarsen

bsharath

ASKER

Can you add this code to the main code please

CSLARSEN

Sub Upd()

Application.EnableEvents = False
Const ADS_PROPERTY_CLEAR = 1
For intRow = 2 To Cells(65536, "L").End(xlUp).Row
strNTLogin = Trim(Cells(intRow, "L").Value)
If strNTLogin <> "" Then
strSeatNo = Trim(Cells(intRow, "B").Value)

If Trim(Cells(intRow, "C").Value) = "KT" then
strBuilding = "44-678"
Else if
Trim(Cells(intRow, "C").Value) = "PJT" then
strBuilding = "44-679"
Else
strBuilding = Trim(Cells(intRow, "C").Value)
End if
strSerialNo = Trim(Cells(intRow, "T").Value)
strExt = Trim(Cells(intRow, "D").Value)
strDepartment = Trim(Cells(intRow, "H").Value)
strTitle = Trim(Cells(intRow, "J").Value)
strMachine = Trim(Cells(intRow, "Q").Value)
strManager = Trim(Cells(intRow, "BI").Value)
strEmail = Trim(Cells(intRow, "O").Value)
strEmpId = Trim(Cells(intRow, "E").Value)
If strManager <> "" Then
strManagerDN = Get_LDAP_User_Properties("user", "name", strManager, "distinguishedName")
Else
strManagerDN = ""
End If
If InStr(strManagerDN, "^") > 0 Then strManagerDN = Split(strManagerDN, "^")(1)
strADsPath = Get_LDAP_User_Properties("user", "samAccountName", strNTLogin, "adsPath")
If InStr(strADsPath, "^") > 0 Then strADsPath = Split(strADsPath, "^")(1)
If InStr(strADsPath, "LDAP://") > 0 Then
Set objUser = GetObject(strADsPath)
boolChanged = False

If UCase(objUser.physicalDeliveryOfficeName) <> UCase(strBuilding) Then
With Cells(intRow, "C").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strSeatNo <> "" Then
objUser.physicalDeliveryOfficeName = UCase(strBuilding)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "physicalDeliveryOfficeName", 0
End If
End If

If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-391" & strExt & ")") Then
With Cells(intRow, "D").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strExt <> "" Then
objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-391" & strExt & ")")
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
End If
End If

If UCase(objUser.Department) <> UCase(strDepartment) Then
With Cells(intRow, "H").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strDepartment <> "" Then
objUser.Department = strDepartment
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "department", 0
End If
End If

If UCase(objUser.Title) <> UCase(strTitle) Then
With Cells(intRow, "J").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strTitle <> "" Then
objUser.Title = strTitle
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "title", 0
End If
End If

strNotesText = "EMP ID : " & strEmpId & vbCrLf & "EMAIL ADDRESS : " & strEmail & vbCrLf & "Machine Name : " & strMachine & vbCrLf & "Location : " & strSeatNo & vbCrLf & "Serial Number : " & strSerialNo
If UCase(objUser.Info) <> UCase(strNotesText) Then
With Cells(intRow, "B").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "Q").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "T").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strMachine <> "" Then
objUser.Info = UCase(strNotesText)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "info", 0
End If
End If

If InStr(strManagerDN, "CN=") > 0 Then
If objUser.Manager <> "" Then
If UCase(Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)) <> UCase(strManager) Then
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
objUser.SetInfo
objUser.Manager = strManagerDN
End If
Else
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.Manager = strManagerDN
End If
ElseIf objUser.Manager <> "" Then
' Clear the Manager
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
End If

If boolChanged = True Then
objUser.SetInfo
End If
Set objUser = Nothing
End If
End If
Next
Application.EnableEvents = True
End Sub

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)

If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If

strDetails = ""
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
Else
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop

' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strDetails

End Function

bsharath

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Next without For
---------------------------
OK Help
---------------------------

bsharath

ASKER

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Next without For
---------------------------
OK Help
---------------------------

CSLARSEN

Sub Upd()

Application.EnableEvents = False
Const ADS_PROPERTY_CLEAR = 1
For intRow = 2 To Cells(65536, "L").End(xlUp).Row
strNTLogin = Trim(Cells(intRow, "L").Value)
If strNTLogin <> "" Then
strSeatNo = Trim(Cells(intRow, "B").Value)

If Trim(Cells(intRow, "C").Value) = "KT" then
strBuilding = "44-678"
End if
IF Trim(Cells(intRow, "C").Value) = "PJT" then
strBuilding = "44-679"
Else
strBuilding = Trim(Cells(intRow, "C").Value)
End if
strSerialNo = Trim(Cells(intRow, "T").Value)
strExt = Trim(Cells(intRow, "D").Value)
strDepartment = Trim(Cells(intRow, "H").Value)
strTitle = Trim(Cells(intRow, "J").Value)
strMachine = Trim(Cells(intRow, "Q").Value)
strManager = Trim(Cells(intRow, "BI").Value)
strEmail = Trim(Cells(intRow, "O").Value)
strEmpId = Trim(Cells(intRow, "E").Value)
If strManager <> "" Then
strManagerDN = Get_LDAP_User_Properties("user", "name", strManager, "distinguishedName")
Else
strManagerDN = ""
End If
If InStr(strManagerDN, "^") > 0 Then strManagerDN = Split(strManagerDN, "^")(1)
strADsPath = Get_LDAP_User_Properties("user", "samAccountName", strNTLogin, "adsPath")
If InStr(strADsPath, "^") > 0 Then strADsPath = Split(strADsPath, "^")(1)
If InStr(strADsPath, "LDAP://") > 0 Then
Set objUser = GetObject(strADsPath)
boolChanged = False

If UCase(objUser.physicalDeliveryOfficeName) <> UCase(strBuilding) Then
With Cells(intRow, "C").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strSeatNo <> "" Then
objUser.physicalDeliveryOfficeName = UCase(strBuilding)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "physicalDeliveryOfficeName", 0
End If
End If

If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-391" & strExt & ")") Then
With Cells(intRow, "D").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strExt <> "" Then
objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-391" & strExt & ")")
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
End If
End If

If UCase(objUser.Department) <> UCase(strDepartment) Then
With Cells(intRow, "H").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strDepartment <> "" Then
objUser.Department = strDepartment
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "department", 0
End If
End If

If UCase(objUser.Title) <> UCase(strTitle) Then
With Cells(intRow, "J").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strTitle <> "" Then
objUser.Title = strTitle
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "title", 0
End If
End If

strNotesText = "EMP ID : " & strEmpId & vbCrLf & "EMAIL ADDRESS : " & strEmail & vbCrLf & "Machine Name : " & strMachine & vbCrLf & "Location : " & strSeatNo & vbCrLf & "Serial Number : " & strSerialNo
If UCase(objUser.Info) <> UCase(strNotesText) Then
With Cells(intRow, "B").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "Q").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "T").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strMachine <> "" Then
objUser.Info = UCase(strNotesText)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "info", 0
End If
End If

If InStr(strManagerDN, "CN=") > 0 Then
If objUser.Manager <> "" Then
If UCase(Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)) <> UCase(strManager) Then
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
objUser.SetInfo
objUser.Manager = strManagerDN
End If
Else
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.Manager = strManagerDN
End If
ElseIf objUser.Manager <> "" Then
' Clear the Manager
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
End If

If boolChanged = True Then
objUser.SetInfo
End If
Set objUser = Nothing
End If
End If
Next
Application.EnableEvents = True
End Sub

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)

If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If

strDetails = ""
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
Else
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop

' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strDetails

End Function

bsharath

ASKER

CSLARSEN
It works but it does not update the right place

it gets updated in building and for few it does nothing

bsharath

ASKER

If PJT it updates the no in the office box in AD not extension and updates the 381 no
if KT it updates updates 381 no

CSLARSEN

Ok I understood it should be updated in column C, in which column would you like to have the information put?
and your second comment I simply do not understand.

bsharath

ASKER

What i meant was
When the data in colum C is "KT" it has to update the colum D data into the extension as "44-678" & the colum "D" cell data
and
If data as "PJT" then update the extension in Ad as "44-679" & the ceolum "D" cell data

Else update as "04-391" & Colum "D" data
Actuall the telephone box data looks like this with the original code....

EXT:- Colum D data (04-391-Colum D data)

I want the same way the code has to update in AD with the "KT" or "PJT" too

The format has to be same for all the 3 types

CSLARSEN

Sub Upd()

Application.EnableEvents = False
Const ADS_PROPERTY_CLEAR = 1
For intRow = 2 To Cells(65536, "L").End(xlUp).Row
strNTLogin = Trim(Cells(intRow, "L").Value)
If strNTLogin <> "" Then
strSeatNo = Trim(Cells(intRow, "B").Value)
strBuilding = Trim(Cells(intRow, "C").Value)

If Trim(Cells(intRow, "C").Value) = "KT" then
strExt = "44-678" & Trim(Cells(intRow, "D").Value)

End if
IF Trim(Cells(intRow, "C").Value) = "PJT" then
strExt = "44-679" & Trim(Cells(intRow, "D").Value)
Else
strExt = "04-391" & Trim(Cells(intRow, "D").Value)
End if
strSerialNo = Trim(Cells(intRow, "T").Value)
strDepartment = Trim(Cells(intRow, "H").Value)
strTitle = Trim(Cells(intRow, "J").Value)
strMachine = Trim(Cells(intRow, "Q").Value)
strManager = Trim(Cells(intRow, "BI").Value)
strEmail = Trim(Cells(intRow, "O").Value)
strEmpId = Trim(Cells(intRow, "E").Value)
If strManager <> "" Then
strManagerDN = Get_LDAP_User_Properties("user", "name", strManager, "distinguishedName")
Else
strManagerDN = ""
End If
If InStr(strManagerDN, "^") > 0 Then strManagerDN = Split(strManagerDN, "^")(1)
strADsPath = Get_LDAP_User_Properties("user", "samAccountName", strNTLogin, "adsPath")
If InStr(strADsPath, "^") > 0 Then strADsPath = Split(strADsPath, "^")(1)
If InStr(strADsPath, "LDAP://") > 0 Then
Set objUser = GetObject(strADsPath)
boolChanged = False

If UCase(objUser.physicalDeliveryOfficeName) <> UCase(strBuilding) Then
With Cells(intRow, "C").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strSeatNo <> "" Then
objUser.physicalDeliveryOfficeName = UCase(strBuilding)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "physicalDeliveryOfficeName", 0
End If
End If

If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-391" & strExt & ")") Then
With Cells(intRow, "D").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strExt <> "" Then
objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-391" & strExt & ")")
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
End If
End If

If UCase(objUser.Department) <> UCase(strDepartment) Then
With Cells(intRow, "H").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strDepartment <> "" Then
objUser.Department = strDepartment
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "department", 0
End If
End If

If UCase(objUser.Title) <> UCase(strTitle) Then
With Cells(intRow, "J").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strTitle <> "" Then
objUser.Title = strTitle
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "title", 0
End If
End If

strNotesText = "EMP ID : " & strEmpId & vbCrLf & "EMAIL ADDRESS : " & strEmail & vbCrLf & "Machine Name : " & strMachine & vbCrLf & "Location : " & strSeatNo & vbCrLf & "Serial Number : " & strSerialNo
If UCase(objUser.Info) <> UCase(strNotesText) Then
With Cells(intRow, "B").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "Q").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With Cells(intRow, "T").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
If strMachine <> "" Then
objUser.Info = UCase(strNotesText)
Else
objUser.PutEx ADS_PROPERTY_CLEAR, "info", 0
End If
End If

If InStr(strManagerDN, "CN=") > 0 Then
If objUser.Manager <> "" Then
If UCase(Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)) <> UCase(strManager) Then
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
objUser.SetInfo
objUser.Manager = strManagerDN
End If
Else
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.Manager = strManagerDN
End If
ElseIf objUser.Manager <> "" Then
' Clear the Manager
With Cells(intRow, "BI").Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
boolChanged = True
objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
End If

If boolChanged = True Then
objUser.SetInfo
End If
Set objUser = Nothing
End If
End If
Next
Application.EnableEvents = True
End Sub

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)

If InStr(strObjectToGet, "\") > 0 Then
arrGroupBits = Split(strObjectToGet, "\")
strDC = arrGroupBits(0)
strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
strObjectToGet = arrGroupBits(1)
Else
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
End If

strDetails = ""
strBase = "<LDAP://" & strDNSDomain & ">"
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

' Filter on user objects.
'strFilter = "(&(objectCategory=person)(objectClass=user))"
strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

' Comma delimited list of attribute values to retrieve.
strAttributes = strCommaDelimProps
arrProperties = Split(strCommaDelimProps, ",")

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute
' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
' Retrieve values and display.
For intCount = LBound(arrProperties) To UBound(arrProperties)
If strDetails = "" Then
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
Else
If IsArray(adoRecordset.Fields(intCount)) = False Then
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
Else
strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
End If
End If
Next
' Move to the next record in the recordset.
adoRecordset.MoveNext
Loop

' Clean up.
adoRecordset.Close
adoConnection.Close
Get_LDAP_User_Properties = strDetails

End Function

bsharath

ASKER

Thank U its much better now...
You can see this line does a change in the extension box
If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-391" & strExt & ")") Then

Can the same thing happen for others too...
One more thing is the "KT" gets the else affected and not the "KT" no updated....

bsharath

ASKER

SOLUTION

CSLARSEN

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

bsharath

ASKER

Its much better but does not update the 2nd half

Actuall when it updates the extension box
It looks as this for KT

EXT:44-678-8888 (44-678-8888)

But now it looks as this

EXT:44-678-8888 (04-391044-3921-8888)

I feel the code in the snippet needs to be different for the other 2 cases as well.
Thanks for the patient help....

If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-381" & strExt & ")") Then
                    With Cells(intRow, "D").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strExt <> "" Then
                        objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-381" & strExt & ")")
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
                    End If
                End If

Open in new window

bsharath

ASKER

If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & " (04-381" & strExt & ")") Then
                    With Cells(intRow, "D").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strExt <> "" Then
                        objUser.telephoneNumber = UCase("Ext:" & strExt & " (04-381" & strExt & ")")
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
                    End If
                End If

Open in new window

RobSampson

Hi Sharath, I haven't gone through the changes that CSLARSEN made above, but I have just added this section to your code:

If strBuilding = "KT" Then
strArea = " (44-678"
ElseIf strBuilding = "PJT" Then
strArea = " (44-679"
Else
strArea = " (04-391"
End If

and replaced the two hard coded instances of this:
" (04-391"

with this
strArea

so that it should insert the correct area number depending on the building.

Regards,

Rob.

Sub Upd()
 
    Application.EnableEvents = False
    Const ADS_PROPERTY_CLEAR = 1
    For intRow = 2 To Cells(65536, "L").End(xlUp).Row
        strNTLogin = Trim(Cells(intRow, "L").Value)
        If strNTLogin <> "" Then
            strSeatNo = Trim(Cells(intRow, "B").Value)
            strBuilding = Trim(Cells(intRow, "C").Value)
            strSerialNo = Trim(Cells(intRow, "T").Value)
            strExt = Trim(Cells(intRow, "D").Value)
            strDepartment = Trim(Cells(intRow, "H").Value)
            strTitle = Trim(Cells(intRow, "J").Value)
            strMachine = Trim(Cells(intRow, "Q").Value)
            strManager = Trim(Cells(intRow, "BI").Value)
            strEmail = Trim(Cells(intRow, "O").Value)
            strEmpId = Trim(Cells(intRow, "E").Value)
            If strManager <> "" Then
                strManagerDN = Get_LDAP_User_Properties("user", "name", strManager, "distinguishedName")
            Else
                strManagerDN = ""
            End If
            If InStr(strManagerDN, "^") > 0 Then strManagerDN = Split(strManagerDN, "^")(1)
            strADsPath = Get_LDAP_User_Properties("user", "samAccountName", strNTLogin, "adsPath")
            If InStr(strADsPath, "^") > 0 Then strADsPath = Split(strADsPath, "^")(1)
            If InStr(strADsPath, "LDAP://") > 0 Then
                Set objUser = GetObject(strADsPath)
                boolChanged = False
                
                If UCase(objUser.physicalDeliveryOfficeName) <> UCase(strBuilding) Then
                    With Cells(intRow, "C").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strSeatNo <> "" Then
                        objUser.physicalDeliveryOfficeName = UCase(strBuilding)
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "physicalDeliveryOfficeName", 0
                    End If
                End If
                
                If strBuilding = "KT" Then
                    strArea = " (44-678"
                ElseIf strBuilding = "PJT" Then
                    strArea = " (44-679"
                Else
                    strArea = " (04-391"
                End If
                
                If UCase(objUser.telephoneNumber) <> UCase("Ext:" & strExt & strArea & strExt & ")") Then
                    With Cells(intRow, "D").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strExt <> "" Then
                        objUser.telephoneNumber = UCase("Ext:" & strExt & strArea & strExt & ")")
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "telephoneNumber", 0
                    End If
                End If
 
                If UCase(objUser.Department) <> UCase(strDepartment) Then
                    With Cells(intRow, "H").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strDepartment <> "" Then
                        objUser.Department = strDepartment
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "department", 0
                    End If
                End If
 
                If UCase(objUser.Title) <> UCase(strTitle) Then
                    With Cells(intRow, "J").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strTitle <> "" Then
                        objUser.Title = strTitle
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "title", 0
                    End If
                End If
                
                strNotesText = "EMP ID : " & strEmpId & vbCrLf & "EMAIL ADDRESS : " & strEmail & vbCrLf & "Machine Name : " & strMachine & vbCrLf & "Location : " & strSeatNo & vbCrLf & "Serial Number : " & strSerialNo
                If UCase(objUser.Info) <> UCase(strNotesText) Then
                    With Cells(intRow, "B").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    With Cells(intRow, "Q").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    With Cells(intRow, "T").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    If strMachine <> "" Then
                        objUser.Info = UCase(strNotesText)
                    Else
                        objUser.PutEx ADS_PROPERTY_CLEAR, "info", 0
                    End If
                End If
                
                If InStr(strManagerDN, "CN=") > 0 Then
                    If objUser.Manager <> "" Then
                        If UCase(Mid(Left(objUser.Manager, InStr(objUser.Manager, ",") - 1), 4)) <> UCase(strManager) Then
                            With Cells(intRow, "BI").Interior
                                .ColorIndex = 36
                                .Pattern = xlSolid
                                .PatternColorIndex = xlAutomatic
                            End With
                            boolChanged = True
                            objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
                            objUser.SetInfo
                            objUser.Manager = strManagerDN
                        End If
                    Else
                        With Cells(intRow, "BI").Interior
                            .ColorIndex = 36
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                        End With
                        boolChanged = True
                        objUser.Manager = strManagerDN
                    End If
                ElseIf objUser.Manager <> "" Then
                    ' Clear the Manager
                    With Cells(intRow, "BI").Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                    End With
                    boolChanged = True
                    objUser.PutEx ADS_PROPERTY_CLEAR, "Manager", 0
                End If
                
                If boolChanged = True Then
                    objUser.SetInfo
                End If
                Set objUser = Nothing
            End If
        End If
    Next
    Application.EnableEvents = True
End Sub
 
Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
      
      If InStr(strObjectToGet, "\") > 0 Then
            arrGroupBits = Split(strObjectToGet, "\")
            strDC = arrGroupBits(0)
            strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
            strObjectToGet = arrGroupBits(1)
      Else
            Set objRootDSE = GetObject("LDAP://RootDSE")
            strDNSDomain = objRootDSE.Get("defaultNamingContext")
      End If
 
      strDetails = ""
      strBase = "<LDAP://" & strDNSDomain & ">"
      ' Setup ADO objects.
      Set adoCommand = CreateObject("ADODB.Command")
      Set ADOConnection = CreateObject("ADODB.Connection")
      ADOConnection.Provider = "ADsDSOObject"
      ADOConnection.Open "Active Directory Provider"
      adoCommand.ActiveConnection = ADOConnection
 
 
      ' Filter on user objects.
      'strFilter = "(&(objectCategory=person)(objectClass=user))"
      strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"
 
      ' Comma delimited list of attribute values to retrieve.
      strAttributes = strCommaDelimProps
      arrProperties = Split(strCommaDelimProps, ",")
 
      ' Construct the LDAP syntax query.
      strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
      adoCommand.CommandText = strQuery
      adoCommand.Properties("Page Size") = 100
      adoCommand.Properties("Timeout") = 30
      adoCommand.Properties("Cache Results") = False
 
      ' Run the query.
      Set adoRecordset = adoCommand.Execute
      ' Enumerate the resulting recordset.
      Do Until adoRecordset.EOF
          ' Retrieve values and display.
          For intCount = LBound(arrProperties) To UBound(arrProperties)
                If strDetails = "" Then
                    If IsArray(adoRecordset.Fields(intCount)) = False Then
                      strDetails = adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
                    Else
                      strDetails = adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
                    End If
                Else
                    If IsArray(adoRecordset.Fields(intCount)) = False Then
                      strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & adoRecordset.Fields(intCount).Value
                    Else
                      strDetails = strDetails & "|" & adoRecordset.Fields(intCount).Name & "^" & Join(adoRecordset.Fields(intCount).Value)
                    End If
                End If
          Next
          ' Move to the next record in the recordset.
          adoRecordset.MoveNext
      Loop
 
      ' Clean up.
      adoRecordset.Close
      ADOConnection.Close
      Get_LDAP_User_Properties = strDetails
 
End Function

Open in new window

bsharath

ASKER

Thanks Rob works perfect...
One addition
Can i get the colum "B" cell data also updated in the place where the extension is updated. Telephone no

EXT:-88 (044-392-88) (Colum B data)

bsharath

ASKER

Thanks Rob works perfect...
One addition
Can i get the colum "B" cell data also updated in the place where the extension is updated. Telephone no

EXT:-88 (044-392-88) (Colum B data)

ASKER CERTIFIED SOLUTION

RobSampson

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

bsharath

ASKER

Thank you both for this help...