Entered data in excel sheet need to retrieve from Ads.

Sharath, this appears to be only some of the code....can you upload a sample database?

Rob.

Rob here is the attached file that looks like.
When entered the EMP id.Thats the description it needs to get the other details as per the colums...
Input-output-from-ADS.xls

attached is code
https://www.experts-exchange.com/questions/23077684/Excel-to-take-the-input-from-the-cells-and-retrive-data-from-ADS-Active-directory.html?anchorAnswerId=20650024#a20650024

This only worked when entered a NTlogin in Samaccount colum not otheres.

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
                      strDetails = adoRecordset.Fields(intCount).Value
                Else
                      strDetails = strDetails & vbCrLf & adoRecordset.Fields(intCount).Value
                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

Select allOpen in new window

OK, just quickly, here's the original with any field able to be entered into.

Regards,

Rob.
Retrieve-Other-AD-Data-Based-On-.xls

Rob this is an excellent one....Thanks a lot...
But Rob as my file attached i need the colums as that file.
Need to put this code on my existing file.
So need just be able to enter the Emp id and get the other details as per the colums in the file.
I should be able to enter just the description.All the others can be removed.


This was a excellent macro that could get info from any colum entered.I was about to ask this question too.

Rob when entered a description it needs to retrieve the data.
But when i type the description (Emp Id) i dont get any data.
Is there some thing i need to do.

Put the word "description" in cell E1.

Above each field in row 2, you need to enter the matching AD field name.

Regards,

Rob.

Rob this is really an extrodinary help for me...
Thanks a lot...

No problem. I actually really like this re-worked version.  It's very good for quickly getting user info....

Thanks to byundt for showing me how to properly use the Target in the Worksheet_Change macro, you can find out which cell has been changed, and update the rest accordingly.

Regards,

Rob.

Rob as i have already some code in the Sheet.Can i place this code in an new module?
I tried it did not work

I already have this macro in the sheet

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
   
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)

   
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
   
    vVal = rngCell.Value
   
    Application.EnableEvents = False
   
    rngCell.ClearContents
   
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
   
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
           
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
   
    Application.EnableEvents = True
   
End Sub


I tried placing both the codes one below the other but get an error.
Any ideas...

Rob what are the headers for "Created date" and "Created time"?

Try this....I've just place both sets of code from each Worksheet_Change procedure into a single one.



Private Sub Worksheet_Change(ByVal Target As Range)
   
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    If intRow > 1 Then
        strObjectType = "user"
        strSearchField = Cells(1, strCol).Value
        strObjectToGet = Cells(intRow, strCol).Value
        strCommaDelimProps = ""
        For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
            If Trim(Cells(1, intCount).Value) <> "" Then
                If strCommaDelimProps = "" Then
                    strCommaDelimProps = Cells(1, intCount).Value
                Else
                    strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                End If
            End If
        Next
        'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
        strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
        arrDetails = Split(strDetails, "|")
        'MsgBox strDetails
        Application.EnableEvents = False
        For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
            For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                    Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                End If
            Next
        Next
        Application.EnableEvents = True
    End If

    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
   
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)

   
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
   
    vVal = rngCell.Value
   
    Application.EnableEvents = False
   
    rngCell.ClearContents
   
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
   
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
           
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
   
    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



Regards,

Rob.

For date and time, they aren't separated in AD.  AD stores them together, in
whenCreated

Regards,

Rob.

Ok Rob..

Sorry for again draging this on a closed Q..

I get a Run time erro.

Debug
  Set adoRecordset = adoCommand.Execute

ScreenShot032.jpg

That's probably due to a mispelled, or non-existent attribute that you're trying to get.

Above this line:
adoCommand.CommandText = strQuery

put
MsgBox strQuery

and make sure that's formatted correctly.

Regards,

Rob.

Rob now i dont get the error.

When inserting a row.Or deleting a row.Copy pasting a bulk rows i get Run time error 13

Rob is it possible to change any of these 2 codes to "Public sub" so that i can run it from a module.

Or is there a way to put these codes in a new modules?

Rob below is the macro which was 2 pieces and combined by Albert for the excel sheet.
Can you combine the code that you gave into this.Or any other possibility please...

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
End Sub
 

Select allOpen in new window

Rob any views on this...

There is no way to make this a Public Sub to go into a module because the Worksheet_Change requires a specific sheet to work in.

The code that you posted, I think it's the same as the combined code I posted in ID 20863799.

Regards,

Rob.

No Rob the last code that i posted is combined with 2 different codes.If possible to combine your code with this that would be great...

Below is the code that i have now in Sheet1.

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
End Sub
 

Select allOpen in new window

Does this work:

Regards,

Rob.

Private Sub Worksheet_Change(ByVal Target As Range)
     
   arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    If intRow > 1 Then
        strObjectType = "user"
        strSearchField = Cells(1, strCol).Value
        strObjectToGet = Cells(intRow, strCol).Value
        strCommaDelimProps = ""
        For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
            If Trim(Cells(1, intCount).Value) <> "" Then
                If strCommaDelimProps = "" Then
                    strCommaDelimProps = Cells(1, intCount).Value
                Else
                    strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                End If
            End If
        Next
        'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
        strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
        arrDetails = Split(strDetails, "|")
        'MsgBox strDetails
        Application.EnableEvents = False
        For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
            For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                    Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                End If
            Next
        Next
        Application.EnableEvents = True
    End If
     
     Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    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

Select allOpen in new window

Rob i get a run time error when i try to move 1 machine from 1 row to another
Debug
   Set adoRecordset = adoCommand.Execute


ScreenShot034.jpg

Rob when i try to move a machine from 1 sheet to another i get run time error 13
Debug
 strObjectToGet = Cells(intRow, strCol).Value

When you debug, which line does it highlight?

Rob.

Runtime error 13
Type mismatch
When clicked debug goes here

        strObjectToGet = Cells(intRow, strCol).Value

Rob a glance on this too plz...

In place of my code within your Worksheet_Change macro, use this.  This will allow you to delete rows now.

Regards.

Rob.

    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If

Select allOpen in new window

Is this the whole code Rob which has to be in the sheet1?

No, just a replacement of my part from these lines
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed


to these lines
            Next
            Application.EnableEvents = True
        End If
    End If


I'm not sure what your current code in the sheet......this section I provided will fix the deletion of rows.

Regards,

Rob.

Rob sorry could not get to it...
I get a compile error.

Below is the full code in Sheet1 "Desktops"

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
End Sub
 

Select allOpen in new window

Try this.

Regards,

Rob.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
End Sub

Select allOpen in new window

Rob i just tried but none worked.
Name entered retrieve data from ADS
Machinename entered swap seats
Move machines and data between sheets
None of the 3 tasks worked...

Oh I forgot the Get_LDAP_User_Properties function. Place this on the bottom of the all of that code.

Rob.

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

Select allOpen in new window

The code also appears to be missing a MoveData function that someone else gave you previously?

Do you have that?

I haven't been following what you have previously, so it's hard to combine.

Rob.

Sorry my mistake..

In another sheet which helps move between sheets
Sheetname "StocK"
I have this


Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Desktops"), Target, "Q"
    End If

'You will put those 4 lines of code in every worksheets Change event that you want it to work on.
'The MoveData line has 3 arguments...you can change the first or last one
'The first argument...Sheets("Sheet2")...is the sheet to get the data from
'The second argument...Target...will never change
'The third argument..."Q"...is the column you want to start the copy from and go to the end of the row
'It was set to "E" originally, but you wanted to change it to "Q"
'Now you can set it to be anything you want by changing that last argument



End Sub




In another sheet "Resigned"
I have this...
Private Sub Worksheet_Change(ByVal Target As Range)
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Desktops"), Target, "E"
    End If
 
End Sub



In one module i have this...


Option Explicit

Public Sub MoveData(SourchSh As Worksheet, DestTarget As Range, StartCopyColumn As String)
Dim r As Range
Dim MaxRow As Long

    MaxRow = SourchSh.Range("Q" & SourchSh.Cells.Rows.Count).End(xlUp).Row
    Set r = SourchSh.Range("Q2")
        Do Until UCase(Trim(r.Value)) = UCase(Trim(DestTarget.Value))
            Set r = r.Offset(1, 0)
                If r.Row > MaxRow Then
                    MsgBox "This value was not found in the second sheet"
                    Exit Sub
                End If
        Loop
        SourchSh.Range(StartCopyColumn & r.Row & ":" & "IV" & r.Row).Copy DestTarget.Offset(0, -(DestTarget.Column - Range(StartCopyColumn & 1).Column))
        SourchSh.Range(StartCopyColumn & r.Row & ":" & "IV" & r.Row).ClearContents
       
End Sub

Now i have the below code in "Desktops" sheet.Is that right
But still nothing happens...

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    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

Select allOpen in new window

Rob i combined both the macros and now they work fine...
I dont know what happened .I created a new file and put in all the codes and they work on that file...
Thanks a lot for the help...

Rob one more ..Post please...
My boss is kicking me off for this...

https://www.experts-exchange.com/questions/23158890/Excel-Macro-when-clicked-update-button-in-one-sheet-needs-to-start-the-query-and-check-multiple-sheets.html

Rob one last favor on this question please..Below is the updated code given by Albert with one added functionality.
Can you add your code with this one and give me so that i can put it in Sheet1

Sorry for the trouble...Its the same way you did before but with the different code...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim CopyFromRow As Long
Dim CopyToRow As Long
Dim MaxRowB As Long
Dim Temp2 As String
 
MaxRowB = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Target.Column = 17 Then
    
    If Target.Value <> "" Then ' And tempStr <> "" Then
        If Target.Value <> tempStr Then
            Application.EnableEvents = False
            Temp2 = Target.Value
            Target.Value = tempStr
            Set r = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp)
                Do Until UCase(r.Value) = UCase(Temp2)
                    If r.Row = 1 Then
                        Target.Value = Temp2
                        If tempStr = "" Then GoTo nxt
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                    Set r = r.Offset(-1, 0)
                Loop
                CopyFromRow = r.Row
                CopyToRow = Target.Row
                Target.Value = tempStr
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & MaxRowB)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).Copy Range("E" & CopyToRow)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).ClearContents
                Application.EnableEvents = True
                Exit Sub
        End If
    End If
End If
 
nxt:
    If Target.Column = 17 And Target.Value <> "" Then
        Application.EnableEvents = False
        MoveData Sheets("Sheet2"), Target, "Q"
        Application.EnableEvents = True
    End If
 
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
 
If Target.Column = 17 Then
    tempStr = Target.Value
End If
 
 
End Sub

Select allOpen in new window

Rob one last favor on this question please..Below is the updated code given by Albert with one added functionality.
Can you add your code with this one and give me so that i can put it in Sheet1

Sorry for the trouble...Its the same way you did before but with the different code...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim CopyFromRow As Long
Dim CopyToRow As Long
Dim MaxRowB As Long
Dim Temp2 As String
 
MaxRowB = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Target.Column = 17 Then
    
    If Target.Value <> "" Then ' And tempStr <> "" Then
        If Target.Value <> tempStr Then
            Application.EnableEvents = False
            Temp2 = Target.Value
            Target.Value = tempStr
            Set r = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp)
                Do Until UCase(r.Value) = UCase(Temp2)
                    If r.Row = 1 Then
                        Target.Value = Temp2
                        If tempStr = "" Then GoTo nxt
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                    Set r = r.Offset(-1, 0)
                Loop
                CopyFromRow = r.Row
                CopyToRow = Target.Row
                Target.Value = tempStr
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & MaxRowB)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).Copy Range("E" & CopyToRow)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).ClearContents
                Application.EnableEvents = True
                Exit Sub
        End If
    End If
End If
 
nxt:
    If Target.Column = 17 And Target.Value <> "" Then
        Application.EnableEvents = False
        MoveData Sheets("Sheet2"), Target, "Q"
        Application.EnableEvents = True
    End If
 
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
 
If Target.Column = 17 Then
    tempStr = Target.Value
End If
 
 
End Sub

Select allOpen in new window

Sharath, I have included this with my code to get information, Alberts other code to move the row, and the one you just posted.

Regards,

Rob.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
Dim r As Range
Dim CopyFromRow As Long
Dim CopyToRow As Long
Dim MaxRowB As Long
Dim Temp2 As String
 
MaxRowB = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Target.Column = 17 Then
    
    If Target.Value <> "" Then ' And tempStr <> "" Then
        If Target.Value <> tempStr Then
            Application.EnableEvents = False
            Temp2 = Target.Value
            Target.Value = tempStr
            Set r = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp)
                Do Until UCase(r.Value) = UCase(Temp2)
                    If r.Row = 1 Then
                        Target.Value = Temp2
                        If tempStr = "" Then GoTo nxt
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                    Set r = r.Offset(-1, 0)
                Loop
                CopyFromRow = r.Row
                CopyToRow = Target.Row
                Target.Value = tempStr
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & MaxRowB)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).Copy Range("E" & CopyToRow)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).ClearContents
                Application.EnableEvents = True
                Exit Sub
        End If
    End If
End If
 
nxt:
    If Target.Column = 17 And Target.Value <> "" Then
        Application.EnableEvents = False
        MoveData Sheets("Sheet2"), Target, "Q"
        Application.EnableEvents = True
    End If
 
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
 
If Target.Column = 17 Then
    tempStr = Target.Value
End If
 
 
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

Select allOpen in new window

Rob i get run time error 424
Object required.

Debug goes to

If Target.Count > 1 Then Exit Sub

Rob i get run time error 424
Object required.

Debug goes to

If Target.Count > 1 Then Exit Sub

That's odd....is it in the Worksheet_Change sub?

Rob.

Rob .
When entering a input it works fine without an error.It gets the data from ADS.
Only when i swap the machine between rows or put the machine name on an existing machine row i get the error.

>>That's odd....is it in the Worksheet_Change sub?
Could not follow the above...

Rob .
When entering a input it works fine without an error.It gets the data from ADS.
Only when i swap the machine between rows or put the machine name on an existing machine row i get the error.

>>That's odd....is it in the Worksheet_Change sub?
Could not follow the above...

I think the issue might be with this sub:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub

If Target.Column = 17 Then
    tempStr = Target.Value
End If
 
 
End Sub



If you comment all of that out, does it work?

Rob.

I  still get run time error 424

I  still get run time error 424

Hmmm, can you post a sample file with your code in it?

Rob.

Here is the attached file Rob

There are many macros in this.

1. File save on everytime it opens
2. Retriev data from ADS when name or emp id entered.
3. Swap between sheets
4. Swap between rows
5. Swap between rows if already exists move to end of page.
6. OS and Sp's
2-15-2008-At-10-42-22-Desktop-de.xls

For which action do you recieve the run-time error?

Rob.

When i put the machine name from ColumQ to another cell which has a machine already or a blank cell in Colum Q itself.

It seems to work fine for me.....Target.Count should always be a valid statement.

I had problems before where no Worksheet_Change macros would run for me at all, but after I shut down Excel completetly (and quitted any excel.exe via Task Manager), it worked again....

Regards,

Rob.

YEs Rob even i did the same and woks now.Except the latest addd option by Albert.
When a row has a machine details already.And when placed the new machine name on it.It just over rites the old one.
Actually it needs to move the old data to end of sheet and then place the new data.

YEs Rob even i did the same and woks now.Except the latest addd option by Albert.
When a row has a machine details already.And when placed the new machine name on it.It just over rites the old one.
Actually it needs to move the old data to end of sheet and then place the new data.

Hi Rob...
Today in the "HALL OF FAME" list you are in the 10th position... Great... Going...... :-)

Rob by any chance if you are working today.Please have a look at these...

https://www.experts-exchange.com/questions/23165634/Dell-Warranty-check-from-website-through-Excel-Macro-Need-tio-change-Rob's-vbs-to-excel-Macro.html
https://www.experts-exchange.com/questions/23165564/Vbs-script-convert-to-excel-Macro-to-find-Ram-slots-and-size.html
https://www.experts-exchange.com/questions/23165549/Excel-Macro-to-find-if-the-machine-is-a-64bit-or-32bit-machine-Convert-this-batch-to-Excel-Macro.html

Hmmm, this is a bit confusing with so many things happening on column Q....try this as all of the code in the Desktops sheet.

Regards,

Rob.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    Application.EnableEvents = True
    
MaxRowB = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Target.Column = 17 Then
    
    If Target.Value <> "" Then ' And tempStr <> "" Then
        If Target.Value <> tempStr Then
            Application.EnableEvents = False
            Temp2 = Target.Value
            Target.Value = tempStr
            Set r = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp)
                Do Until UCase(r.Value) = UCase(Temp2)
                    If r.Row = 1 Then
                        Target.Value = Temp2
                        If tempStr = "" Then GoTo nxt
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                    Set r = r.Offset(-1, 0)
                Loop
                CopyFromRow = r.Row
                CopyToRow = Target.Row
                Target.Value = tempStr
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & MaxRowB)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).Copy Range("E" & CopyToRow)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).ClearContents
                Application.EnableEvents = True
                Exit Sub
        End If
    End If
End If
 
nxt:
    If Target.Column = 17 And Target.Value <> "" Then
        Application.EnableEvents = False
        MoveData Sheets("Sheet2"), Target, "Q"
        Application.EnableEvents = True
    End If
 
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
 
If Target.Column = 17 Then
    tempStr = Target.Value
End If
 
 
End Sub

Select allOpen in new window

Rob i get error.
When coping a machine name to another blank cell.
When i copy the machine name to a cell that has a data already present.
Even for the macro that you gave me to retrieve data from ADS.

Rob if you feel this is confusing can you give me your own macro to do all these things...

Rob i get error.
When coping a machine name to another blank cell.
When i copy the machine name to a cell that has a data already present.
Even for the macro that you gave me to retrieve data from ADS.

Rob if you feel this is confusing can you give me your own macro to do all these things...

ScreenShot004.bmp
ScreenShot005.bmp

Sharath, I'm thinking we look at this a bit different, based on something someone suggested that I didn't think of.  Instead of combing multiple Worksheet_Change macros into one, a better idea to to change all of the Worksheet_Change macro names to something else, then use one Worksheet_Change macro (in each workbook) to "call" those new macro names.

For example, you originaly had (I think) three Worksheet_Change macros.  One from me, and two from Albert.  So, what we should have done, is change those to say

' NUMBER 1 - instead of Sub Worksheet_Change
Sub GetADDetails(Target as Range)
  ' do the stuff
End Sub

' NUMBER 2 - instead of Sub Worksheet_Change
Sub Move_Row(Target as Range)
  ' do the stuff
End Sub

' NUMBER 3 - instead of Sub Worksheet_Change
Sub FindDuplicateRow(Target as Range)
  ' do the stuff
End Sub

and then, use just one Worksheet_Change macro
Sub Worksheet_Change(Target as Range)
   Call GetADDetails(Target)
   Call Move_Row(Target)
   Call FindDuplicateRow(Target)
End Sub


So, is it possible that you have each of these original Worksheet_Change macros, so that we can change them as above?

Regards,

Rob.

Ok Rob...

All the other codes i think 3 codes are combined below...
1. Copy data from cone cell to another will switch machines data between rows.
2. Machine name entered in sheet 2 will get data from sheet 1 and viseversa
3. Machine name placed on existing name will get the old data to End of sheet.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    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

Select allOpen in new window

Ok Rob...

All the other codes i think 3 codes are combined below...
1. Copy data from cone cell to another will switch machines data between rows.
2. Machine name entered in sheet 2 will get data from sheet 1 and viseversa
3. Machine name placed on existing name will get the old data to End of sheet.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
     
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
    
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
    
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
    
    vVal = rngCell.Value
    
    Application.EnableEvents = False
    
    rngCell.ClearContents
    
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
    
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
            
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
    
    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

Select allOpen in new window

OK, try this code as the code in the <SheetName> --> View Code section:

Private Sub Worksheet_Change(ByVal Target As Range)
    Call GetADData(Target)
    Call SearchForSeat(Target)
    Call MoveRow(Target)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
     
    If Target.Column = 17 Then
        tempStr = Target.Value
    End If
End Sub


And then this code is able to go into a Module of it's own if you like.  This actually answers a question taht you had a long while back where you asked if you could turn Worksheet_Change macros into Modules.....well I think you can using this method.  I don't know why I didn't think of it earlier.....

Sub GetADData(ByVal Target As Range)
    arrAddress = Split(Mid(Target.Address, 2), "$")
    strCol = arrAddress(0)
    intRow = arrAddress(1)
    ' Avoid multiple cells being changed
    If InStr(strCol, ":") = 0 And InStr(intRow, ":") = 0 Then
        If intRow > 1 Then
            strObjectType = "user"
            strSearchField = Cells(1, strCol).Value
            strObjectToGet = Cells(intRow, strCol).Value
            strCommaDelimProps = ""
            For intCount = 1 To Cells(1, 256).End(xlToLeft).Column
                If Trim(Cells(1, intCount).Value) <> "" Then
                    If strCommaDelimProps = "" Then
                        strCommaDelimProps = Cells(1, intCount).Value
                    Else
                        strCommaDelimProps = strCommaDelimProps & "," & Cells(1, intCount).Value
                    End If
                End If
            Next
            'MsgBox "Get_LDAP_User_Properties(" & strObjectType & "," & strSearchField & "," & strObjectToGet & "," & strCommaDelimProps & ")"
            strDetails = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
            arrDetails = Split(strDetails, "|")
            'MsgBox strDetails
            Application.EnableEvents = False
            For intCount = LBound(arrDetails) + 1 To UBound(arrDetails) + 1
                For intCol = 1 To Cells(1, 256).End(xlToLeft).Column
                    If LCase(Cells(1, intCol).Value) = LCase(Split(arrDetails(intCount - 1), "^")(0)) Then
                        Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                    End If
                Next
            Next
            Application.EnableEvents = True
        End If
    End If
 
End Sub

Sub SearchForSeat(ByVal Target As Range)
    Dim rngCell As Range
    Dim sAddress As String
    Dim rngSearchArea As Range
    Dim rngMatch As Range
    Dim vVal As Variant
    Dim vPos As Variant
    Dim iFirstCol As Integer
    Dim iLastCol As Integer
 
 
If Target.Count > 1 Then Exit Sub
    If Target.Column = 17 And Target.Value <> "" Then
        MoveData Sheets("Stock"), Target, "Q"
    End If
 
 
   
    Set rngSearchArea = Me.Range("Q1").EntireColumn
    Set rngCell = Intersect(Target, rngSearchArea)
 
   
    If rngCell Is Nothing Then
        Exit Sub
    ElseIf rngCell.Cells.Count > 1 Then
        MsgBox "You have changed more than one cell in column Q. Data lookup is cancelled!"
    End If
   
    vVal = rngCell.Value
   
    Application.EnableEvents = False
   
    rngCell.ClearContents
   
    On Error Resume Next
    vPos = Application.WorksheetFunction.Match(vVal, rngSearchArea, 0)
    On Error GoTo 0
   
    If Not IsEmpty(vPos) Then
        iFirstCol = 5 'The first column to be moved (E)
        iLastCol = Me.Columns.Count 'The last column to be moved
        Set rngMatch = rngSearchArea.Cells(vPos)
        sAddress = rngMatch.Address
        With Me
            .Range(.Cells(rngMatch.Row, iFirstCol), .Cells(rngMatch.Row, iLastCol)).Cut _
            Destination:=.Range(.Cells(rngCell.Row, iFirstCol), .Cells(rngCell.Row, iLastCol))
           
            .Range(sAddress).Offset(0, -1).Value = "Free Seat"
        End With
    Else
        rngCell.Value = vVal
    End If
   
    Application.EnableEvents = True
   
End Sub

Sub MoveRow(ByVal Target As Range)
MaxRowB = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp).Row + 1
 
If Target.Count > 1 Then Exit Sub
If Target.Column = 17 Then
   
    If Target.Value <> "" Then ' And tempStr <> "" Then
        If Target.Value <> tempStr Then
            Application.EnableEvents = False
            Temp2 = Target.Value
            Target.Value = tempStr
            Set r = Range("Q" & ActiveSheet.Cells.Rows.Count).End(xlUp)
                Do Until UCase(r.Value) = UCase(Temp2)
                    If r.Row = 1 Then
                        Target.Value = Temp2
                        If tempStr = "" Then GoTo nxt
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                    Set r = r.Offset(-1, 0)
                Loop
                CopyFromRow = r.Row
                CopyToRow = Target.Row
                Target.Value = tempStr
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & MaxRowB)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).Copy Range("E" & CopyToRow)
                Range("E" & CopyFromRow & ":" & "IV" & CopyFromRow).ClearContents
                Application.EnableEvents = True
                Exit Sub
        End If
    End If
End If
 
nxt:
    If Target.Column = 17 And Target.Value <> "" Then
        Application.EnableEvents = False
        MoveData Sheets("Sheet2"), Target, "Q"
        Application.EnableEvents = True
    End If
 
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



Regards,

Rob.

Rob should this part be in Sheet1

Private Sub Worksheet_Change(ByVal Target As Range)
    Call GetADData(Target)
    Call SearchForSeat(Target)
    Call MoveRow(Target)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
     
    If Target.Column = 17 Then
        tempStr = Target.Value
    End If
End Sub



And the rest in a module?
If yes then i got a compile error

Rob should this part be in Sheet1

Private Sub Worksheet_Change(ByVal Target As Range)
    Call GetADData(Target)
    Call SearchForSeat(Target)
    Call MoveRow(Target)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
     
    If Target.Column = 17 Then
        tempStr = Target.Value
    End If
End Sub



And the rest in a module?
If yes then i got a compile error

OK, the workbook that you posted in ID: 20899583, I have changed that into Modules, with just the Worksheet_Change sub in the sheet....

Regards,

Rob.
2-15-2008-At-10-42-22-Desktop-de.xls

Ok Rob works fine thanks.....
This method looks great....

Ok Rob works fine thanks.....
This method looks great....

Rob a little help on this Q .Its relevent to the post here
https://www.experts-exchange.com/questions/23266926/When-entered-data-in-excel-retrieve-the-details-from-ADS-Active-directory.html