Uniquenos UDF

B

Bayo

Below is from a post dated 2004 by Ron Rosenfeld. It is supposed to
check the comma seperated numbers in a cell and filter unique ones and
show in sorted. Example given was 1,2,3,4,2,3,4,1,5,2,5,3 should be
shown 1,2,3,4,5. In fact, it does so with these numbers. But when the
numbers are 2,3,4,2,3,4,1,5,2, it comes up as 2,2,3,4,5 (1 disappears
and duplicate 2s). Or 9,31,5,4,11,12 becomes 9,12,31,4,5 (11
dissappears).
I usually try and modify the codes, however this is too complicated for
me. I am more into listing unique values, sorting would be an
additional good function, however not really a must.
Any help will be very much appreciated.

**********************************
Function UniqueNos(str As String) As String
Dim Temp, Temp2
Dim i As Integer, j As Integer

Temp = Split(str, ",")
ReDim Temp2(0)
BubbleSort Temp

Temp2(0) = Temp(0)
j = 0

For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
Temp2(j) = Temp(i)
End If
Next i

UniqueNos = Join(Temp2, ",")

End Function

Function BubbleSort(TempArray As Variant)
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 1 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)

End Function
****************************

Regards,

Bayo
 
B

Bob Phillips

Very straightforward, just change this line

For i = 1 To UBound(TempArray) - 1


to

For i = LBound(TempArray) To UBound(TempArray) - 1

in the BubbleSort function

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)
 
R

Ron Rosenfeld

Very straightforward, just change this line

For i = 1 To UBound(TempArray) - 1


to

For i = LBound(TempArray) To UBound(TempArray) - 1

in the BubbleSort function
Click to expand...

Nice catch.

I don't know where that '1' came from. On the version I have in my add-in on
my computer, it shows as a '0' which would work, also.


--ron
 
R

Ron Rosenfeld

Below is from a post dated 2004 by Ron Rosenfeld. It is supposed to
check the comma seperated numbers in a cell and filter unique ones and
show in sorted. Example given was 1,2,3,4,2,3,4,1,5,2,5,3 should be
shown 1,2,3,4,5. In fact, it does so with these numbers. But when the
numbers are 2,3,4,2,3,4,1,5,2, it comes up as 2,2,3,4,5 (1 disappears
and duplicate 2s). Or 9,31,5,4,11,12 becomes 9,12,31,4,5 (11
dissappears).
I usually try and modify the codes, however this is too complicated for
me. I am more into listing unique values, sorting would be an
additional good function, however not really a must.
Any help will be very much appreciated.

**********************************
Function UniqueNos(str As String) As String
Dim Temp, Temp2
Dim i As Integer, j As Integer

Temp = Split(str, ",")
ReDim Temp2(0)
BubbleSort Temp

Temp2(0) = Temp(0)
j = 0

For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
Temp2(j) = Temp(i)
End If
Next i

UniqueNos = Join(Temp2, ",")

End Function

Function BubbleSort(TempArray As Variant)
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 1 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)

End Function
****************************

Regards,

Bayo
Click to expand...

There's an error in the Bubblesort routine.

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
--> For i = 0 To UBound(TempArray) - 1
^^^

That line needs to be changed.

Or, as Bob suggested, you could also change the '1' to LBound(TempArray)


--ron
 
B

Bayo

Thank you very much to both of you. I tried and kept both corrections
and both work perfect, I think it sorts according first digit, like 25
is in front of 3, it returns 1,2,25,3,35,42,5 etc...however it is still
OK after having the unique values.

Really great help and of course and excellent UDF (still have to work
on it to understand...).

Regards,

Merry X-Mas and Happy Many Years...
Bayo
 
R

Ron Rosenfeld

Thank you very much to both of you. I tried and kept both corrections
and both work perfect, I think it sorts according first digit, like 25
is in front of 3, it returns 1,2,25,3,35,42,5 etc...however it is still
OK after having the unique values.

Really great help and of course and excellent UDF (still have to work
on it to understand...).

Regards,

Merry X-Mas and Happy Many Years...
Bayo
Click to expand...

The purpose of the function is to return unique values. It will work with
either numbers or non-numeric values.

The purpose of the sorting routine is NOT to be able to return the values in a
sorted order, but rather to place identical values "next to each other" so the
non-unique values can be more readily identified. Using this technique, it
happens that the values are returned in an alpha sorted order.

For this purpose the values are all handled as strings.

If you want to return the values sorted numerically (as opposed to the alpha
sort which is presently the case), you can convert the values to numbers, and
then resort.

For example: (--> marks the changed lines)

============================
....
For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
--> Temp2(j) = IIf(IsNumeric(Temp(i)), Val(Temp(i)), Temp(i))
End If
Next i

--> BubbleSort Temp2

UniqueNos = Join(Temp2, ",")

End Function
============================


--ron
 
B

Bayo

Ron said:
The purpose of the function is to return unique values. It will work with
either numbers or non-numeric values.

The purpose of the sorting routine is NOT to be able to return the values in a
sorted order, but rather to place identical values "next to each other" so the
non-unique values can be more readily identified. Using this technique, it
happens that the values are returned in an alpha sorted order.

For this purpose the values are all handled as strings.

If you want to return the values sorted numerically (as opposed to the alpha
sort which is presently the case), you can convert the values to numbers, and
then resort.

For example: (--> marks the changed lines)

============================
...
For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
--> Temp2(j) = IIf(IsNumeric(Temp(i)), Val(Temp(i)), Temp(i))
End If
Next i

--> BubbleSort Temp2

UniqueNos = Join(Temp2, ",")

End Function
============================


--ron
Click to expand...

Thanks Ron,
That works fine when I place a comma in front of initial entry,
otherwhise, first number appears in the result and then the remaining
ones appear in sorted order.


Regards,
Baybars
 
R

Ron Rosenfeld

Thanks Ron,
That works fine when I place a comma in front of initial entry,
otherwhise, first number appears in the result and then the remaining
ones appear in sorted order.


Regards,
Baybars
Click to expand...

Sorry about that. The conversion of text to numbers, the way I wrote it,
leaves out the 0th element of the array. So that was always remaining as a
text string and getting sorted to the end.

Here's another version that should take care of that issue, and give a
numerically sorted output, with text at the end:

====================================
Option Explicit
Function UniqueNos(str As String) As String
Dim Temp, Temp2
Dim i As Integer, j As Integer

Temp = Split(str, ",")
ReDim Temp2(0)
Bubblesrt Temp

Temp2(0) = Temp(0)
j = 0

For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
Temp2(j) = Temp(i)
End If
Next i

For j = 0 To UBound(Temp2)
Temp2(j) = IIf(IsNumeric(Temp2(j)), Val(Temp2(j)), Temp2(j))
Next j
Bubblesrt Temp2

UniqueNos = Join(Temp2, ",")

End Function

Function Bubblesrt(TempArray As Variant)
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 0 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)

End Function
===========================


--ron
 
B

Bayo

Ron said:
Sorry about that. The conversion of text to numbers, the way I wrote it,
leaves out the 0th element of the array. So that was always remaining as a
text string and getting sorted to the end.

Here's another version that should take care of that issue, and give a
numerically sorted output, with text at the end:

====================================
Option Explicit
Function UniqueNos(str As String) As String
Dim Temp, Temp2
Dim i As Integer, j As Integer

Temp = Split(str, ",")
ReDim Temp2(0)
Bubblesrt Temp

Temp2(0) = Temp(0)
j = 0

For i = 1 To UBound(Temp)
If Temp(i) > Temp(i - 1) Then
j = j + 1
ReDim Preserve Temp2(j)
Temp2(j) = Temp(i)
End If
Next i

For j = 0 To UBound(Temp2)
Temp2(j) = IIf(IsNumeric(Temp2(j)), Val(Temp2(j)), Temp2(j))
Next j
Bubblesrt Temp2

UniqueNos = Join(Temp2, ",")

End Function

Function Bubblesrt(TempArray As Variant)
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 0 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)

End Function
===========================


--ron
Click to expand...


Ron,
This is absolutely perfect...

Thanks a lot...

Happy New Year...
Baybars
 
R

Ron Rosenfeld

Ron,
This is absolutely perfect...

Thanks a lot...

Happy New Year...
Baybars
Click to expand...

You're welcome. Thanks for pointing out the problems, so I could make them
right.
--ron
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Export to PDF 0
sorting an array 5
VBA Coding Help for Beginner 0
help with this error-Compile error: cant find project or library 2
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Use range to move data between worksheets 2
AddPicturesToShapes 0
Word macro that can call cells out of Excel for a find and replace 0

Top