Advertisement

10.03.2008 at 02:14AM PDT, ID: 23784359
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
9.1

Excel code that retrieves all data from ADS. Need a change.

Asked by bsharath in Microsoft Excel Spreadsheet Software, Microsoft Office Suite, Scripting Languages

Tags: , ,

Hi,

Excel code that retrieves all data from ADS. Need a change.
It actually gets details when a Nt login is entered in colum "L"
Now i want it to work when entered a EMP id in Colum "E"

How can i get this done. What are the changes i need to do?

Regards
Sharath


Start Free Trial 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim tVal As String
Dim sCount As Integer
Dim sVal
Dim c As New Collection
Dim r As Range
Dim PasteRow As Long
Dim rowAV As String
 
Application.EnableEvents = False
    'CreateUndoSheets
 
    'Capitalizes first letter of all data entered
    '******************
    If Target.Count = 1 Then
        Target.Value = MakeCaps(Target)
    End If
    '***************
        
 
Dim r3 As Range
'rRow2 is row where dupe was found
 
    
If Target.Count > 1 Then GoTo nxt
If Target.Column <> 17 Then GoTo nxt
 
    'If the value entered already exists somewhere
    If ChkDupes(Target.Value, Target) = True Then
        Application.EnableEvents = False
             'If target row is not blank
            If n <> "" Then
                Set r3 = Range("P" & Cells.Rows.Count).End(xlUp).Offset(1, 0)
                Seat1 = Range("B" & rRow2).Value
                Seat2 = Range("B" & Target.Row).Value
                Seat3 = Range("B" & Target.Row).Value
                If Seat1 = "" Then Seat1 = "Unknown"
                If Seat2 = "" Then Seat2 = "Unknown"
                If Seat3 = "" Then Seat3 = "Unknown"
                
                Target.Value = n
                Range("E" & Target.Row & ":" & "IV" & Target.Row).Copy Range("E" & r3.Row)
                Range("E" & rRow2 & ":" & "IV" & rRow2).Copy Range("E" & Target.Row)
                    Range("E" & rRow2 & ":" & "AU" & rRow2).ClearContents
                    Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearContents
                    Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearComments
                    Range("E" & rRow2 & ":" & "AU" & rRow2).ClearComments
               Range("P" & rRow2).Value = "Free seat"
                n = Target.Value
                FormatRow Range("E" & r3.Row).EntireRow
                
                If Range("T" & Target.Row).Comment Is Nothing Then
                    Range("T" & Target.Row).AddComment "******************"
                End If
                
            '**************
            Seat4 = Range("K" & Target.Row).Value
            If Seat4 = "" Then Seat4 = "Unknown"
                Range("T" & Target.Row).Comment.Text Range("T" & Target.Row).Comment.Text & Chr(10) & Now & _
                  Chr(10) & "Swapped from seat " & Chr(10) & Seat1 & Chr(10) & "to seat " & Chr(10) & Seat2 & Chr(10) & _
                   "Owner" & Chr(10) & Seat4 & Chr(10) & "******************" ' & Chr(10)
                
                Range("T" & Target.Row).Comment.Shape.TextFrame.AutoSize = True
                
                Range("T" & rRow2).NoteText ""
                
                If Range("T" & r3.Row).Comment Is Nothing Then
                    Range("T" & r3.Row).AddComment "******************"
                End If
                
                Range("T" & r3.Row).Comment.Text Range("T" & r3.Row).Comment.Text & Chr(10) & Now & _
                  Chr(10) & "Swapped from seat " & Chr(10) & Seat3 & Chr(10) & "to end (Unknown) " & Chr(10) & "******************" ' & Chr(10)
                
                Range("T" & r3.Row).Comment.Shape.TextFrame.AutoSize = True
            '************
                 
                 
                 'comment for column B
                If Target.Offset(0, -15).Comment Is Nothing Then
                    Target.Offset(0, -15).AddComment
                    Target.Offset(0, -15).Comment.Text "******************"
                End If
           
                Target.Offset(0, -15).Comment.Text Target.Offset(0, -15).Comment.Text & "Date: " & DateValue(Now()) & _
                 Chr(10) & "Machine name: " & Range("Q" & Target.Row).Value & Chr(10) & "Emp Id: " & Range("E" & Target.Row).Value & Chr(10) & _
                    "NT Login: " & Range("L" & Target.Row).Value & Chr(10) & "******************"
                   Target.Offset(0, -15).Comment.Shape.TextFrame.AutoSize = True
                
                
                
                If Range("B" & r3.Row).Comment Is Nothing Then
                    Range("B" & r3.Row).AddComment
                End If
                Range("B" & r3.Row).Comment.Text Range("B" & r3.Row).Comment.Text & Chr(10) & "Date: " & DateValue(Now()) & _
                 Chr(10) & "Machine name: " & Range("Q" & r3.Row).Value & Chr(10) & "Emp Id: " & Range("E" & r3.Row).Value & Chr(10) & _
                   "NT Login: " & Range("L" & r3.Row).Value & Chr(10) & "******************"
                   Range("B" & r3.Row).Comment.Shape.TextFrame.AutoSize = True
           
            
            
            
            Else 'If target row is blank
                Seat1 = Range("B" & rRow2).Value
                Seat2 = Range("B" & Target.Row).Value
                If Seat1 = "" Then Seat1 = "Unknown"
                If Seat2 = "" Then Seat2 = "Unknown"
                
                Target.Value = n
                Range("E" & rRow2 & ":" & "IV" & rRow2).Copy Range("E" & Target.Row)
                    Range("E" & rRow2 & ":" & "AU" & rRow2).ClearContents
                    Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearContents
                    
                Range("P" & rRow2).Value = "Free seat"
                Range("P" & Target.Row).Value = "Desktop"
                FormatRow Range("E" & Target.Row).EntireRow
                n = Target.Value
                
                    Range("E" & rRow2 & ":" & "K" & rRow2).ClearComments
                    Range("M" & rRow2 & ":" & "AU" & rRow2).ClearComments
                    Range("AW" & rRow2 & ":" & "IV" & rRow2).ClearComments
                    Range("L" & rRow2).ClearComments
        
        'comment for column B
        If Target.Offset(0, -15).Comment Is Nothing Then
            Target.Offset(0, -15).AddComment
            Target.Offset(0, -15).Comment.Text "******************"
        End If
        Target.Offset(0, -15).Comment.Text Target.Offset(0, -15).Comment.Text & Chr(10) & "Date: " & DateValue(Now()) & _
         Chr(10) & "Machine Name: " & Range("Q" & Target.Row).Value & Chr(10) & "Emp Id: " & Range("E" & Target.Row).Value & Chr(10) & _
           "NT Login: " & Range("L" & Target.Row).Value & Chr(10) & "******************"
           Target.Offset(0, -15).Comment.Shape.TextFrame.AutoSize = True
                 
            '**************
                If Range("T" & Target.Row).Comment Is Nothing Then
                    Range("T" & Target.Row).AddComment "******************"
                End If
            
            Seat4 = Range("K" & Target.Row).Value
            If Seat4 = "" Then Seat4 = "Unknown"
                Range("T" & Target.Row).Comment.Text Range("T" & Target.Row).Comment.Text & Chr(10) & Now & _
                  Chr(10) & "Swapped from seat " & Chr(10) & Seat1 & Chr(10) & _
                  "to seat " & Chr(10) & Seat2 & Chr(10) & "Owner" & Chr(10) & Seat4 & Chr(10) & "******************" ' & Chr(10)
                
                Range("T" & Target.Row).Comment.Shape.TextFrame.AutoSize = True
                
                Range("T" & rRow2).NoteText ""
            '**************
            End If
    'If the value entered does not exist on this sheet (ChkDupes was false)
    Else
        If Target.Value <> "" Then
            'If Target.Value <> n Then 'if a cell was changed to a different value it already was
                'rowAV = Cells(Target.Row, "AV")
                Seat2 = Range("B" & Target.Row).Value
                
                MoveData Sheets("Stock"), Target, "Q", True
                Range("P" & Target.Row).Value = "Desktop" 'Uncomment this line to have column p in Desktops sheet change to "Desktop" when swapped from the Stocks sheet
                'Cells(Target.Row, "AV") = rowAV
                If NotFound = False Then
            '**************
                    If Seat1 = "" Then Seat1 = "Unknown"
                    If Seat2 = "" Then Seat2 = "Unknown"
                    If Seat4 = "" Then Seat4 = "Unknown"
                    
                    If Range("T" & Target.Row).Comment Is Nothing Then
                        Range("T" & Target.Row).AddComment "******************"
                    End If
                    
                    Range("T" & Target.Row).Comment.Text Range("T" & Target.Row).Comment.Text & Chr(10) & Now & _
                     Chr(10) & "Moved from Stocks - seat " & Chr(10) & Seat1 & Chr(10) & "to Desktops - seat " & _
                      Chr(10) & Seat2 & Chr(10) & "Owner" & Chr(10) & Seat4 & Chr(10) & "******************" ' & Chr(10)
'                    Range("T" & Target.Row).NoteText ""
                    Range("T" & Target.Row).Comment.Shape.TextFrame.AutoSize = True
                    
                    If Range("L" & Target.Row).Comment Is Nothing Then
                        Range("L" & Target.Row).AddComment "******************" & Chr(10)
                        Range("L" & Target.Row).Comment.Text Range("L" & Target.Row).Comment.Text & _
                         "Present machine" & Chr(10) & "Date: " & DateValue(Now()) & _
                          Chr(10) & Range("Q" & Target.Row).Value & Chr(10) & "******************"
                    Else
                        Range("L" & Target.Row).Comment.Text Range("L" & Target.Row).Comment.Text & _
                         Chr(10) & "Replaced machine from Stock" & Chr(10) & "Date: " & DateValue(Now()) & _
                          Chr(10) & Range("Q" & Target.Row).Value & Chr(10) & "******************"
                        Range("L" & Target.Row).Comment.Shape.TextFrame.AutoSize = True
                    End If
                    
            '**************
                End If
                
                'Comment for column B
                If Target.Offset(0, -15).Comment Is Nothing Then
                    Target.Offset(0, -15).AddComment
                    Target.Offset(0, -15).Comment.Text "******************"
                End If
                Target.Offset(0, -15).Comment.Text Target.Offset(0, -15).Comment.Text & Chr(10) & "Date: " & DateValue(Now()) & _
                 Chr(10) & "Macine Name: " & Range("Q" & Target.Row).Value & Chr(10) & "Emp Id: " & Range("E" & Target.Row).Value & Chr(10) & _
                   "NT Login: " & Range("L" & Target.Row).Value & Chr(10) & "******************"
                   Target.Offset(0, -15).Comment.Shape.TextFrame.AutoSize = True
        
        
        
        'End If
        
    End If
End If
nxt:
 
 
    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
            If LCase(strSearchField) = "samaccountname" Then
                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
                'Specify which column has your Name (full name) attribute. This
                ' is required to get the email address from the same Contact if it
                ' cannot be found in the user object
                strFullNameColumn = "K"
                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
                            If LCase(Split(arrDetails(intCount - 1), "^")(0)) = "mail" Then
 
                                If Trim(Split(arrDetails(intCount - 1), "^")(1)) <> "" Then
                                    Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                                Else
                                    If LCase(strSearchField) <> "mail" Then
                                        strObjectType = "contact"
                                        strSearchField = "name"
                                        strObjectToGet = Cells(intRow, strFullNameColumn).Value
                                        strCommaDelimProps = "mail"
                                        strContactMail = Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)
                                           If UBound(Split(strContactMail, "^")) = 1 Then
                                            Cells(intRow, intCol).Value = Split(strContactMail, "^")(1)
                                        Else
                                            Cells(intRow, intCol).Value = strContactMail
                                        End If
 
                                    End If
                                End If
 
                            ElseIf LCase(Split(arrDetails(intCount - 1), "^")(0)) = "manager" Then
                                If Trim(Split(arrDetails(intCount - 1), "^")(1)) <> "" Then
                                    strManager = Split(arrDetails(intCount - 1), "^")(1)
                                    strManager = Mid(strManager, 4)
                                    strManager = Left(strManager, InStr(strManager, ",") - 1)
                                    Cells(intRow, intCol).Value = strManager
                                End If
                            ElseIf LCase(Split(arrDetails(intCount - 1), "^")(0)) = "company" Then
                                If InStr(Split(arrDetails(intCount - 1), "^")(1), " ") > 0 Then
                                    Cells(intRow, intCol).Value = Split(Split(arrDetails(intCount - 1), "^")(1), " ")(0)
                                Else
                                    Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                                End If
                            Else
                                Cells(intRow, intCol).Value = Split(arrDetails(intCount - 1), "^")(1)
                            End If
                        End If
                    Next
                Next
            End If
        End If
    End If
 
'
'    'Capitalizes first letter of all data entered
'    '******************
'    If Target.Count = 1 Then
'        Target.Value = MakeCaps(Target)
'    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
 
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  '  If Target.Count > 1 Then Exit Sub
'   If Target.Cells.Count > 1 Then Exit Sub
If (Target.Rows.Count > 1) Or (Target.Columns.Count > 1) Then Exit Sub
    n = Target.Value
    
End Sub
[+][-]10.03.2008 at 03:08AM PDT, ID: 22632388

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]10.05.2008 at 08:50AM PDT, ID: 22645003

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]10.07.2008 at 10:49PM PDT, ID: 22666411

View this solution now by starting your 7-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

 

About this solution

Zones: Microsoft Excel Spreadsheet Software, Microsoft Office Suite, Scripting Languages
Tags: Excel, Macro, Script
Sign Up Now!
Solution Provided By: RobSampson
Participating Experts: 2
Solution Grade: A
 
 
[+][-]10.07.2008 at 11:40PM PDT, ID: 22666632

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]10.08.2008 at 03:51PM PDT, ID: 22674261

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]10.08.2008 at 07:52PM PDT, ID: 22675352

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]10.08.2008 at 07:52PM PDT, ID: 22675353

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
 
Loading Advertisement...
20080716-EE-VQP-32 / EE_QW_EXPERT_20070906