Excel 2010 Macro Remove Duplicate Data from a Range
Sometimes, you have a list of items and only need to list the unique values. The following function goes through a range and stores only the unique values:
UniqueValues (OrigArray)
The argument is OrigArray, an array from which the duplicates will be removed. This first section (Const declarations) must be at the top of the module:
Const ERR_BAD_PARAMETER = “Array parameter required”
Const ERR_BAD_TYPE = “Invalid Type”
Const ERR_BP_NUMBER = 20000
Const ERR_BT_NUMBER = 20001
You can place the following section of code anywhere in the module as long as it is below the previous section:
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 vTest As Variant, 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
An example of this 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