Solved

Posted on 2012-09-21

Hi, I have ranges of numbers in a column of cells, eg

Cell 1 - 13, 14, 15, 13, 11-12, 14, 54, 14, 49, 12, 14, 23, 28-29, 29, 107, 13-14, 15, 18, 54, 14, 25-29, 10, 15, 20, 29

Cell 2 - 12, 28, 44, 44, 59, 60, 61, 61, 42, 58

Some are separated by commas and others are number ranges. I would like to sort the numbers within the ranges and if possible at the same time remove any duplicates.

Any assistance would be much appreciated.

Many thanks

Cell 1 - 13, 14, 15, 13, 11-12, 14, 54, 14, 49, 12, 14, 23, 28-29, 29, 107, 13-14, 15, 18, 54, 14, 25-29, 10, 15, 20, 29

Cell 2 - 12, 28, 44, 44, 59, 60, 61, 61, 42, 58

Some are separated by commas and others are number ranges. I would like to sort the numbers within the ranges and if possible at the same time remove any duplicates.

Any assistance would be much appreciated.

Many thanks

14 Comments

Cell 1: 10, 11-12, 13, 14, 15, 18, 20, 23, 25-29, 49, 54, 107

Cell2: 2, 28, 42, 44, 58, 59, 60, 61

But not sure if it is possible?

2. Why isn't "2 - 12" part of the answer for Cell 2?

here is my take on this.

Put all this in a standard module.

```
Dim dAllNums As Object
Function SORTNUMS(ByRef Num, ByVal Delim As String) As String
Dim dNums As Object
Dim dNum As Object
Dim i As Long
Dim x, y
Set dAllNums = CreateObject("scripting.dictionary")
Set dNums = CreateObject("scripting.dictionary")
Set dNum = CreateObject("scripting.dictionary")
If TypeOf Num Is Range Then Num = Num.Value2
x = Split(Num, Delim)
For i = 0 To UBound(x)
dNums.Item(Split(Trim(x(i)), "-")(0)) = Trim(x(i))
Next
x = SortA(dNums.keys)
For i = LBound(x) To UBound(x)
y = dNums.Item(x(i))
If Not dAllNums.exists(Val(x(i))) Then
dNum.Item(y) = Empty
End If
If InStr(1, y, "-") Then
FillNum Split(y, "-")(0), Val(Split(y, "-")(1))
Else
dAllNums.Item(Val(x(i))) = Empty
End If
Next
SORTNUMS = Join$(dNum.keys, Delim)
End Function
Private Function SortA(ByRef v)
Dim i As Long, j As Long, t
For i = LBound(v) To UBound(v)
For j = i To UBound(v)
If Val(v(j)) < Val(v(i)) Then
t = v(i)
v(i) = v(j)
v(j) = t
End If
Next
Next
SortA = v
End Function
Private Sub FillNum(ByVal StartNum As Long, Optional EndNum As Long)
Dim i As Long
For i = StartNum To EndNum
dAllNums.Item(i) = Empty
Next
End Sub
```

and use like

=SORTNUMS(A1,",")

Kris

I got confused with that too but I figured out that the first dash symbol was not part of the cell contents. It would have been clearer this way:

Cell 1: 13, 14, 15, 13, 11-12, 14, 54, 14, 49, 12, 14, 23, 28-29, 29, 107, 13-14, 15, 18, 54, 14, 25-29, 10, 15, 20, 29

Cell 2: 12, 28, 44, 44, 59, 60, 61, 61, 42, 58

@LetsLearn

Here's a function that you can call to accomplish what you want. You would call this function with something like

```
Function SortCell(sCell As String) As String
Dim sHold As String, sPrev As String, sNext As String
Dim sArr As Variant
Dim i As Integer
sArr = Split(sCell & ",", ",")
i = 1
Do Until i = UBound(sArr)
sPrev = Trim(sArr(i - 1))
sNext = Trim(sArr(i))
If Val(sNext) < Val(sPrev) Then
'swap
sHold = sPrev
sArr(i - 1) = sNext
sArr(i) = sHold
If i > 1 Then i = i - 1
ElseIf sNext = sPrev And (sNext & sPrev) <> "" Then
'remove duplicates
sArr(i - 1) = ""
If i > 1 Then i = i - 1
Else
i = i + 1
End If
Loop
SortCell = Replace(Trim(Join(sArr, " ")), " ", ", ")
End Function
```

10, 11-12, 12, 13, 13-14, 14, 15, 18, 20, 23, 25-29, 28-29, 29, 49, 54, 107

12, 28, 42, 44, 58, 59, 60, 61

Replace FillNum sub with the following

```
Private Sub FillNum(ByVal StartNum As Long, Optional EndNum As Long)
Dim i As Long
If EndNum < StartNum Then EndNum = StartNum
For i = StartNum To EndNum
dAllNums.Item(i) = Empty
Next
End Sub
```

Results showing duplicates.

10, 11-12,

Kris

I just wanted to point out that accepted solution does have some quirks.

For instance, in your original sample, you had a range of 25-29; If you add another range like 24-25, your original range 25-29 disappears. Likewise, if you add 29-30, this new range doesn't even get included.

If you don't anticipate ranges that overlap then it's not a problem, but if you do, then just say so or open another question.

/Ron

Thanks for testing the code.

Here is revised one. This code will group the consecutive numbers, irrespective of the input structure.

```
Dim dAllNums As Object
Function SORTNUMS(ByRef Num, ByVal Delim As String) As String
Dim i As Long
Dim x, y, Flg As Boolean
Set dAllNums = CreateObject("scripting.dictionary")
If TypeOf Num Is Range Then Num = Num.Value2
x = Split(Num, Delim)
For i = 0 To UBound(x)
y = Split(x(i), "-")
If UBound(y) > 0 Then
FillNum Val(y(0)), Val(y(1))
Else
dAllNums.Item(Val(y(0))) = Empty
End If
Next
x = SortA(dAllNums.keys)
For i = LBound(x) + 1 To UBound(x)
If x(i) - x(i - 1) = 1 Then
If Not Flg Then y = x(i - 1): Flg = True
If i = UBound(x) Then SORTNUMS = SORTNUMS & Delim & y & "-" & x(i)
ElseIf x(i) - x(i - 1) > 1 Then
If Not Flg Then
SORTNUMS = SORTNUMS & Delim & x(i - 1)
Flg = False: y = x(i)
Else
If x(i - 1) - y > 1 Then
SORTNUMS = SORTNUMS & Delim & y & "-" & x(i - 1)
Flg = False: y = x(i)
Else
SORTNUMS = SORTNUMS & Delim & y
Flg = False: y = x(i)
End If
End If
If i = UBound(x) Then SORTNUMS = SORTNUMS & Delim & y
End If
Next
If Len(SORTNUMS) > Len(Delim) Then
SORTNUMS = Mid$(SORTNUMS, Len(Delim) + 1)
End If
End Function
Private Function SortA(ByRef v)
Dim i As Long, j As Long, t
For i = LBound(v) To UBound(v)
For j = i To UBound(v)
If Val(v(j)) < Val(v(i)) Then
t = v(i)
v(i) = v(j)
v(j) = t
End If
Next
Next
SortA = v
End Function
Private Sub FillNum(ByVal StartNum As Long, Optional EndNum As Long)
Dim i As Long
If EndNum < StartNum Then EndNum = StartNum
For i = StartNum To EndNum
dAllNums.Item(i) = Empty
Next
End Sub
```

Kris

By clicking you are agreeing to Experts Exchange's Terms of Use.

Title | # Comments | Views | Activity |
---|---|---|---|

how to simplify this IF OR AND functions | 9 | 25 | |

Excel 2010 question | 3 | 23 | |

Updating Pivot Table within VBA | 5 | 28 | |

Need help on countif statements using VBA and excel | 16 | 24 |

Join the community of 500,000 technology professionals and ask your questions.

Connect with top rated Experts

**12** Experts available now in Live!