Deleting Duplicates

[Sara McKibben]

I copied the following VBA Code from VBA and Macros and it only produces the first value in the original array. What is wrong with the code?

Thanks whomever for the assistance

Const ERR_BAD_PARAMETER = "Array Parameter required"
Const ERR_BAD_TYPE = "Invalid Type"
Const ERR_BP_NUMBER = 20000
Const ERR_BT_NUMBER = 20001
Public Function UniqueValues(ByVal OrigArray As Variant) As Variant
Dim vAns() As Variant
Dim lStartPoint As Long
Dim lEndPoint As Long
Dim lCtr As Long, lCount As Long
Dim iCtr As Integer
Dim col As New Collection
Dim sIndex As String
Dim vitem As Variant
Dim iBadVarTypes(4) As Integer
'function does not work if array element is one of the
'following types
iBadVarTypes(0) = vbObject
iBadVarTypes(1) = vbError
iBadVarTypes(2) = vbDataObject
iBadVarTypes(3) = vbUserDefinedType
iBadVarTypes(4) = vbArray
'check to see whether the parameter is an array
If Not IsArray(OrigArray) Then
Err.Raise ERR_BP_NUMBER, , ERR_BAD_PARAMETER
Exit Function
End If
lStartPoint = LBound(OrigArray)
lEndPoint = UBound(OrigArray)
For lCtr = lStartPoint To lEndPoint
vitem = OrigArray(lCtr)
'First check to see whether variable type is acceptable
For iCtr = 0 To UBound(iBadVarTypes)
If VarType(vitem) = iBadVarTypes(iCtr) Or _
VarType(vitem) = iBadVarTypes(iCtr) + vbVariant Then
Err.Raise ERR_BT_NUMBER, , ERR_BAD_TYPE
Exit Function
End If
Next iCtr
'Add element to a collection, using it as the index
'If an error occurs, the element already exists
sIndex = CStr(vitem)
'first element, add automatically
If lCtr = lStartPoint Then
col.Add vitem, sIndex
ReDim vAns(lStartPoint To lStartPoint) As Variant
vAns(lStartPoint) = vitem
Else
On Error Resume Next
col.Add vitem, sIndex
If Err.Number = 0 Then
lCount = UBound(vAns) + 1
ReDim Preserve vAns(lStartPoint To lCount)
vAns(lCount) = vitem
End If
End If
Err.Clear
Next lCtr
UniqueValues = vAns
End Function
Function nodupsArray(rng As Range) As Variant
Dim arr1() As Variant
If rng.Columns.Count > 1 Then Exit Function
arr1 = Application.Transpose(rng)
arr1 = UniqueValues(arr1)
nodupsArray = Application.Transpose(arr1)
End Function