load only one instance(no duplicates)

[white6174]

What I'm trying to do is use either data validation or a list box and have it loaded with text from a range (B4:B100) and have it not load duplicates.

Any ideas would be appreciated

thanks steve w

 

[Kade]

Hi All, Juan pointed me here from a new post I had started

This is exactly my problem!
I have now tried Aladins advanced filter lead and cobbled around it for my needs and it works great.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("dataentrylist")) Is Nothing Then Exit Sub
Range("dataentrylist").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B2" _
), Unique:=True
Range("uniquelist").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

End Sub


Of course when we get what we want, we always want a little bit more

The one shortfall for me is not been able to load future names in the unique list that I know will ultimately be required. (no big deal)

I do not have the code skills, but wondered if the constant refiltering could be avoided by something along these lines.

Dataentrylist = dynamic list manually entered
uniquelistlist = dynamic list automatically compiled

1 Worksheet change, If not in dataentrylist exit sub
2 evaluate if the last entry (new entry) in the dataentrylist occurs in the unique list (counta =>1 ??) if yes - exit sub
3. lastcell.value in dataentrylist = lastcell +1 .value in unique list
4. sort uniquelist

this would permit manual loading of names into the unique list without them being dumped via autofilter process

I am very happy with what I now have, but was just wondering, no need to respond

ta kd

 

[Aladin Akyurek]

...

Dataentrylist = dynamic list manually entered
uniquelistlist = dynamic list automatically compiled

1 Worksheet change, If not in dataentrylist exit sub
2 evaluate if the last entry (new entry) in the dataentrylist occurs in the unique list (counta =>1 ??) if yes - exit sub
3. lastcell.value in dataentrylist = lastcell +1 .value in unique list
4. sort uniquelist

this would permit manual loading of names into the unique list without them being dumped via autofilter process

I am very happy with what I now have, but was just wondering, no need to respond...

I believe my last post in this thread (revised Method 1) with Juan's formula copier would do what you want. The resulting list can be treated as a changing range and named by means of a dynamic formula. The dynamic range name can then be used in data validation.

 

[Kade]

Yes Aladin,

I couldn't get it to work before but I now have it working. When I tried earlier I think some formula became text as I was copy and pasting them from the URL to the spreadsheet . .

After manually typing them in it worked perfect!


ta kd

 

[Corticus]

Aladin,

Excellent

For the VBA-approaches I´m confused why all approaches involves looping through the range.

After all, reading cellvallues into an array (variant) and then loop through the array is much faster.

Nevertheless, excellent Aladin!

Dennis

Perhaps like this?

nodups.xls
	A	B	C	D	E
1	Source		ArrayFunc		StandardFunction
2	A		A		A
3	R		R		R
4	T		T		T
5	A		V		V
6	V		F		F
7	F		EE		EE
8	EE		1		1
9	1		19		19
10	19		Q		Q
11	V		GE		GE
12	Q		123		123
13	V
14	GE
15	V
16	123
17	1
nodups

'declarations
Const ERR_BAD_PARAMETER = "Array parameter required"
Const ERR_BAD_TYPE = "Invalid Type"
Const ERR_BP_NUMBER = 20000
Const ERR_BT_NUMBER = 20001

Function nodupsIndex(rng As Range, ind As Integer) As Variant

    Dim arr1() As Variant

    If rng.Columns.Count > 1 Then Exit Function

    arr1 = Application.Transpose(rng)

    arr1 = UniqueValues(arr1)
    
    nodupsIndex = arr1(ind)
    
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

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 with 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 if 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 if 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

Enjoy!

 

[Cbrine]

I got some great code that will filter a selected listing down to unique values only. It's pretty short and easy. It will only work on a single column of values. Use a copy of the values you want to filter because it erases the duplicates and resorts the values.

Sub TrimList()
Dim wb As Workbook, ws As Worksheet
Dim c As Range
Dim CValue As String

Set wb = Workbooks(ActiveWorkbook.Name)
Set ws = wb.Worksheets(ActiveSheet.Name)

Selection.Sort Range(Left(Selection.Address, InStr(1, Selection.Address, ":") - 1)), xlAscending

For Each c In Selection
CValue = c.Offset(1, 0).Value
If c.Value = CValue Then
c.Clear
Else
CValue = c.Value
End If
Next c
Selection.Sort Range(Left(Selection.Address, InStr(1, Selection.Address, ":") - 1)), xlAscending

End Sub


My 2 cents.

 

[polly]

Originally posted by Aladin Akyurek:
...
What method should be prefered?

(1) Method 3, if you can realize the required setup.

(2) Method 2, if (1) cannot be realized.

(3) Method 1b, if (2) is not possible, simply because your users cannot add required add-in...
--------------------------------------------------------------------------------
What follows is a revised, considerably faster version of Method 1 , which figures for a great deal in...



Aladin Akyurek your a BIG Time saver

I have looked and asked all over for a way to Alphabetize a list of names with formulas. I have tried endlessly to come up with a series of formulas, but never got past the second letter of the name. I modified this series of formulas to work for me & it worked on the first try....I was amazed. It whipped out my list of 84 names in no time! Automatically & will do it even as the names in the list change from year to year!
I also learned some new ways to use some Excel Formula Functions As I ussually do at MrExcel.com

What a GREAT PLACE to keep on learning about EXCEL!!!!!!
Thank You Very Much
Paul Myers

 

[Luthius]

Well, I know that we have a lot of solution, but this code is good to use in Add-in because the list of unique values is get with the selected range of the sheet and I use the object Dictionary to store values inside of loop.

Sub ExtractUniqueValues()
    Dim rngInputRange As Range, rCell As Range
    Dim objDictionary As Object
    
    Set objDictionary = CreateObject("Scripting.Dictionary")
    Set rngInputRange = Selection
        
    For Each rCell In rngInputRange
        With objDictionary
            If Not .exists(rCell.Value) Then
                .Add rCell.Value, rCell.Value
            End If
        End With
    Next rCell
    
    Selection.Clear
    Cells(Selection.Row, Selection.Column).Resize(objDictionary.Count).Value = Application.Transpose(objDictionary.items)
    
    Set objDictionary = Nothing
    Set rngInputRange = Nothing
    Set rCell = Nothing
    
End Sub

Luthius