‘Write values to OUTPUT Worksheet
intWriteRow = 4 this is setting the output line to be always 4 as it is not being used properly within the sub routine

try incrementing writerow at the end of the sub and take out the
intWriteRow = 4 line

and make the variable public. (it is telling the sub to write at line 4 and is not getting incremented as far as i can see, so it keeps writing to line 4, overwriting anything already there.)

My problem is that it is only working partially. To summarize, I am using a single workbook containing two worksheets. Worksheet 1 is where the script reads from, and it is just one column with a list of sAMAccountNames. Worksheet 2 is where the script writes the output to for each of the sAMAccountNames after fetching the values from the domain. My problem seems to be that I do not know how to code the Loop such that it increments to the next Row for each of worksheets as it parses through the sAMAccountNames. As a result, the script succeeds only for the first row (reads input from first row in worksheet 1 and writes output to first row in worksheet2) but it does not process the subsequent rows.

Does anyone know how I can accomplish this loop?

' Abridged original remarks from Ralph Mongtomery
' Get User Information NTUser.wsf
' Version 1.0 Created 11-26-2001 by Ralph Montgomery (rmonty@myself.com)

' Alan Kaplan remarks
' 3/23/2009 I have been using this script for a very long time, and have probably hacked
' it beyond recognition. I take neither the credit nor the blame for the clumsy bits...
' I stripped out Win9x stuff, and system info detection, as everyone I know
' using this is at XP or later.

'10/23/2009 added support for and enumeration of UPN

Option Explicit
Dim strUserName, objUserDomain, objGroup, objUser, strGroupList
Dim WshShell, strMessage, strTitle
Dim oDomain, strNTDomain, strVer
Dim strSortedGroups, arrGroupList, strUserList
Dim objChangePwdTrue, objChangePwd, objUserProfile
Dim objPwdExpiresTrue, objFlags, oPwdExpire, strPwdExpires, iAdminCount, dPwdLastChanged, iAutoUnlock
Dim objAcctDisabled, intPwdExpired, objPwdExpiredTrue, objPwdExpires,bAccountDisabled
Dim StrQuote, iBadLogins, iMaxPadPw, iAccountLockout, iPwdAge, intPwdHistory
Dim strExcelPath, objExcel, objSheet, intReadRow, strUserDN, strPassword, xlExcel7, intWriteRow
Set WshShell = WScript.CreateObject("WScript.Shell")
strVer = "Ver 3.1 "
strQuote = Chr(34)
Dim strNTName, strUPN
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
Const ADS_NAME_TYPE_USER_PRINCIPAL_NAME = 9
Dim strNTUserName
Const ADS_NAME_INITTYPE_DOMAIN = 1
Const ADS_NAME_TYPE_UNKNOWN = 8
Const ADS_NAME_TYPE_CANONICAL = 2

Dim oTrans
Set oTrans = CreateObject("NameTranslate")

' Check for required script arguments
If (Wscript.Arguments.Count < 1) Then
    Wscript.Echo "Arguments <FileName> required. For example:" & vbCrLf _
        & "cscript enumaccountpolicies.vbs c:spreadsheet.xls"
    Wscript.Quit(0)
End If

' Pull Environment variables for domain/user
strNTDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
strNTUserName = ucase(WshShell.ExpandEnvironmentStrings("%USERNAME%"))


	'------------------------------------------MAIN----------------------------------------------
	
	Call Excel
	Call ExcelAddOutputSheet
	Call GetandWriteInfo


	' Format the spreadsheet.
	'objSheet.Range("A1:A5").Font.Bold = True
	'objSheet.Select
	'objSheet.Range("B5").Select
	'objExcel.ActiveWindow.FreezePanes = True
	'objExcel.Columns(1).ColumnWidth = 20
	'objExcel.Columns(2).ColumnWidth = 30
	
	' Save the spreadsheet and close the workbook.
	objExcel.ActiveWorkbook.SaveAs strExcelPath
	objExcel.ActiveWorkbook.Close
	
	' Quit Excel.
	objExcel.Application.Quit
	
	' Clean up.
	Set objUser = Nothing
	Set objExcel = Nothing
	Set objSheet = Nothing
	
	Wscript.Echo "Done"

	'---------------------------------------------END MAIN-------------------------------------------
	
	

'''''''''Subs and Functions ''''''''''

Sub Excel  'Bind to Excel object and Workbook

	' Define Workbook Path
	strExcelPath = Wscript.Arguments(0)
	
	' Bind to Excel object
	On Error Resume Next
	Set objExcel = CreateObject("Excel.Application")
	If (Err.Number <> 0) Then
	On Error GoTo 0
	Wscript.Echo "Excel application not found"
	Wscript.Quit
	End If
	objExcel.Visible = True
	On Error GoTo 0
	
	' Bind to Workbook
	On Error Resume Next
	objExcel.Workbooks.Open strExcelPath
	If (Err.Number <> 0) Then
	On Error GoTo 0
	Wscript.Echo "Spreadsheet cannot be opened: " & strExcelPath
	Wscript.Quit
	End If
	On Error GoTo 0
End Sub


Sub ExcelReadSheet 'Bind to INPUT Worksheet in Workbook
	Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
End Sub


Sub ExcelWritesheet  'Bind to OUTPUT Worksheet in Workbook
	Set objSheet = objExcel.ActiveWorkbook.Worksheets(2)
End Sub


Sub ExcelAddOutputSheet 'Populate Headings in OUTPUT Worksheet
	
	'Bind to OUTPUT worksheet in current Workbook
	Call ExcelWriteSheet
	'Name Worksheet
	objSheet.Name = "Audit Results"
	'Populate
	objSheet.Cells(1, 1).Value = "Account Attributes"
	objSheet.Cells(1, 2).Value = "Date & Time of Retrieval: " & (NOW())
	objSheet.Cells(3, 1).Value = "Full Name"
	objSheet.Cells(3, 2).Value = "Account Name"
	objSheet.Cells(3, 3).Value = "Description"
	objSheet.Cells(3, 4).Value = "Account Disabled"
	objSheet.Cells(3, 5).Value = "Account Locked Out"
	objSheet.Cells(3, 6).Value = "Bad Logins"
	objSheet.Cells(3, 7).Value = "~Last Logon"
	objSheet.Cells(3, 8).Value = "Max Password Attempts"
	objSheet.Cells(3, 9).Value = "Attempts Left"
	objSheet.Cells(3, 10).Value = "Password Never Expires"
	objSheet.Cells(3, 11).Value = "Password Expired?"
	objSheet.Cells(3, 12).Value = "Password Age"
	objSheet.Cells(3, 13).Value = "Password Last Changed"
	objSheet.Cells(3, 14).Value = "Password Next Change"
	objSheet.Cells(3, 15).Value = "User can Change Password"
	objSheet.Cells(3, 16).Value = "Password Minimum Length"
	objSheet.Cells(3, 17).Value = "Passwords Kept in History"
	objSheet.Cells(3, 18).Value = "Lock-out Time"
	objSheet.Cells(3, 19).Value = "Auto-Unlock Time"
	objSheet.Cells(3, 20).Value = "Group Memberships"
End Sub


Sub GetandWriteInfo  'Reads INPUT Worksheet, Fetches Parameters, and writes to OUTPUT Worksheet

	'Read INPUT Worksheet
	Call ExcelReadSheet
	
	'The first row of the input worksheet is skipped (column headings). 
	'Each row after the first is processed until the first blank entry 
	'in the first column is encountered.
	intReadRow = 2
	Do While objSheet.Cells(intReadRow, 1).Value <> ""
	strUserName = objSheet.Cells(intReadRow, 1).Value
	strNTUserName = strUserName
	On Error Resume Next
	
	'Attempt to bind to the user account
	Set objUser = GetObject("WinNT://"& strNTDomain & "/" & strNTUserName & ", user")
	If (Err.Number <> 0) Then
	On Error GoTo 0
	Wscript.Echo "User NOT found: " & strNTUserName 
	
	Else
	
	''''''Fetch Account Parameters''''''
	On Error resume Next
	' Creates the list of groups the user belongs To
	For Each objGroup In objUser.Groups
	If strGroupList = "" Then
	strGroupList = objGroup.Name
	Else
	strGroupList = strGroupList & ", " & objGroup.Name
	End If
	Next
	' Convert strgrouplist to Array
	arrGroupList = Split(strGroupList,",")
	'Sort the darn thing
	Quicksort arrGroupList, LBound(arrGroupList), UBound(arrGroupList)
	' Now concatenate arrGroupList into a variable for display
	strSortedGroups = trim(Join(arrGroupList, ", "))
	
	'check for expired password
	intPwdExpired = objUser.Get("PasswordExpired")
	If intPwdExpired = 1 Then
	objPwdExpiredTrue = "Yes"
	Else objPwdExpiredTrue = "No"
	End If
	
	'Check for Must Change Password Flag
	objFlags = objUser.Get("UserFlags")
	If (objFlags And &H00040) <> 0 Then
	objChangePwdTrue = "No"
	Else objChangePwdTrue = "Yes"
	End If
	
	' Is password set to NEVER expire?
	objPwdExpires = objUser.Get("UserFlags")
	If (objPwdExpires And &H10000) <> 0 Then
	objPwdExpiresTrue = "Yes"
	strPwdExpires = "Date Set: "
	Else objPwdExpiresTrue = "No"
	strPwdExpires = "Password Expires: "
	End If
	
	' Is the account disabled?
	If objUser.AccountDisabled = True Then
	bAccountDisabled = "Yes"
	Else bAccountDisabled = "No"
	End If
	
	'How many wrong logins?
	iBadLogins = objUser.BadPasswordAttempts
	
	'Maximum bad password attempts?
	iMaxPadPw = objUser.MaxBadPasswordsAllowed
	
	'Account Lockout Observation Interval
	iAccountLockout = FormatNumber((objUser.LockoutObservationInterval/60), 0)
	
	'How old is the current password?
	iPwdAge = FormatNumber(((objUser.Get("PasswordAge")/60)/60)/24, 0)
	
	'Calculate the date the password was last changed
	dPwdLastChanged = CStr(objUser.PasswordExpirationDate - objUser.Get("MaxPasswordAge") / (60 * 60 * 24))
	
	iAdminCount = objUser.Get("AdminCount")
	
	'Set Profile path to tabs if blank
	objUserProfile = objUser.Profile
	If objUserProfile = "" Then
	objUserProfile= "<None>" & vbTab
	Else objUserProfile = objUserProfile
	End If
	
	'Determine how many passwords are saved
	Set oDomain = GetObject("WinNT://" & strNTDomain)
	intPwdHistory = oDomain.PasswordHistoryLength
	iAutoUnlock = oDomain.AutoUnlockInterval/60
	
	
	'Bind to OUTPUT Worksheet in current Workbook
	Call ExcelWriteSheet
	'Write results to OUTPUT Worksheet
	Call Writeinfo
	
	End If
	
	'Attempt to process next worksheet rows via Loop
	intReadRow = intReadRow + 1
	'intWriteRow = intWriteRow + 1
	Loop

End Sub 


Sub WriteInfo 'Writes Fetched Parameters to OUTPUT Worksheet
	
	'Write values to OUTPUT Worksheet
	intWriteRow = 4
	objSheet.Cells(intWriteRow, 1).Value = objUser.FullName
	objSheet.Cells(intWriteRow, 2).Value = strNTDomain & "" & strNTUserName
	objSheet.Cells(intWriteRow, 3).Value = objUser.Description
	objSheet.Cells(intWriteRow, 4).Value = bAccountDisabled
	objSheet.Cells(intWriteRow, 5).Value = objUser.IsAccountLocked
	objSheet.Cells(intWriteRow, 6).Value = iBadLogins
	objSheet.Cells(intWriteRow, 7).Value = objUser.LastLogin
	objSheet.Cells(intWriteRow, 8).Value = iMaxPadPw
	objSheet.Cells(intWriteRow, 9).Value = iMaxPadPw - iBadLogins
	objSheet.Cells(intWriteRow, 10).Value = objPwdExpiresTrue
	objSheet.Cells(intWriteRow, 11).Value = objPwdExpiredTrue
	objSheet.Cells(intWriteRow, 12).Value = iPwdAge
	objSheet.Cells(intWriteRow, 13).Value = dPwdLastChanged
	objSheet.Cells(intWriteRow, 14).Value = strPwdExpires
	objSheet.Cells(intWriteRow, 15).Value = objChangePwdTrue
	objSheet.Cells(intWriteRow, 16).Value = objUser.PasswordMinimumLength
	objSheet.Cells(intWriteRow, 17).Value = intPwdHistory & " password(s)"
	objSheet.Cells(intWriteRow, 18).Value = iAccountLockout & " minutes"
	objSheet.Cells(intWriteRow, 19).Value = iAutoUnlock & " minutes"
	objSheet.Cells(intWriteRow, 20).Value = strSortedGroups

End Sub


Sub Quicksort(strValues(), ByVal min, ByVal max) 'Sorts the items in the array (between the two values you pass in)
	Dim strMediumValue, high, low, i
	
	'If the list has only 1 item, it's sorted.
	If min >= max Then Exit Sub
	
	' Pick a dividing item randomly.
	i = min + Int(Rnd(max - min + 1))
	strMediumValue = strValues(i)
	
	' Swap the dividing item to the front of the list.
	strValues(i) = strValues(min)
	
	' Separate the list into sublists.
	low = min
	high = max
	Do
	' Look down from high for a value < strMediumValue.
	Do While strValues(high) >= strMediumValue
	high = high - 1
	If high <= low Then Exit Do
	Loop
	
	If high <= low Then
	'The list is separated.
	strValues(low) = strMediumValue
	Exit Do
	End If
	
	'Swap the low and high strValues.
	strValues(low) = strValues(high)
	
	'Look up from low for a value >= strMediumValue.
	low = low + 1
	Do While strValues(low) < strMediumValue
	low = low + 1
	If low >= high Then Exit Do
	Loop
	
	If low >= high Then
	'The list is separated.
	low = high
	strValues(high) = strMediumValue
	Exit Do
	End If
	
	'Swap the low and high strValues.
	strValues(high) = strValues(low)
	Loop 'Loop until the list is separated.
	
	'Recursively sort the sublists.
	Quicksort strValues, min, low - 1
	Quicksort strValues, low + 1, max

End Sub


Function GetUPN (strNTName)
	On Error Resume Next
	oTrans.Init ADS_NAME_INITTYPE_GC, ""
	oTrans.Set ADS_NAME_TYPE_UNKNOWN,strNTName
	If Err <> 0 Then
	MsgBox "Unable to lookup " & strNTName,vbCritical + vbOKOnly,"Error"
	WScript.Quit
	End If
	GetUPN = oTrans.Get(5)
End Function


Function GetNTPath (strUPN)
	On Error Resume next
	oTrans.Init ADS_NAME_INITTYPE_GC, ""
	oTrans.Set ADS_NAME_TYPE_USER_PRINCIPAL_NAME,strUPN
	If Err <> 0 Then
	MsgBox "Unable to lookup " & strUPN,vbCritical + vbOKOnly,"Error"
	WScript.Quit
	End If
	
	GetNTPath = oTrans.Get(ADS_NAME_TYPE_NT4)
	GetNTPath = Replace(GetNTPath,"","/")
End Function