Finding Consecutive Numbers

[waderw]

I am looking for some help/code to test to see if certain values in a selected cell are consecutive. For ex. in cell "B6" I have the numbers "1,2,3,5,7,8,9". I want to format "1,2,3" and "7,8,9" as "1-3" and "7-9" and then add the 5 so my output in the cell looks like this: "1-3,5,7-9".

Any suggestions or recommendations?

[Chris Davison]

do you digits only go as high as "9" or do they go higher ?

(ie 456)

are they all integers, or could some be decimals

(ie 45.6)

how many numbers are in your cell ? is it always 7 as per your example or could it be less and/or more ?

(ie 1,2,3,4,5,7,8,9,10,11,12,13,14)

Are they always seperated by commas ?

and lastly....(!).... do they always run from minimum to maximum, left to right ?

[waderw]

There could be 'n' numbers in the cell. Ranging from 0-nnn. They are all integers, separted by commas and can be in any order.

Thanks!

[Tom Schreiner]

This sounds like a fun little project...
Will you email me the sheet?
TsTom@Hotmail.com
Thanks,
TOm

[zacemmel]

I was thinking it would be fairly easy to do that, but there are some variables that would make it difficult. The fact that integer length can change would make it tough. I think I can do this for you, though. Just give me a few minutes here and I should have that for you.

Zac

[zacemmel]

This code should work, just add it to a module:

Sub number()
Dim sPos As Integer
Dim lPos As Integer
Dim cPos As Integer
Dim xTime As Integer
Dim curVar As Integer
Dim lasVar As Integer
Dim nVar As Integer
Dim nPos As Integer
cPos = 1
sPos = 1
lasVar = InStr(sPos, Range("a1").Value, ",")
Do While cPos > 0
xTime = xTime + 1
cPos = InStr(sPos, Range("a1").Value, ",")
nPos = InStr(cPos + 1, Range("a1").Value, ",")
If xTime > 1 Then
If cPos = 0 Then
curVar = Mid(Range("a1").Value, sPos, Len(Range("a1").Value))
Else
curVar = Mid(Range("a1").Value, sPos, cPos - lPos - 1)
If nPos > 0 Then
nVar = Mid(Range("a1").Value, cPos + 1, nPos - cPos - 1)
End If
End If
Else
curVar = Mid(Range("a1").Value, sPos, cPos - 1)
nVar = Mid(Range("a1").Value, cPos + 1, nPos - cPos - 1)
End If
If nVar - 1 = curVar Then
gotime = 1
Else
If gotime = 1 Then
If xTime > 1 Then
output = output & "," & lasVar & "-" & curVar
Else
output = lasVar & "-" & curVar
End If
Else
If xTime > 1 Then
output = output & "," & curVar
Else
output = curVar
End If
End If
lasVar = nVar
gotime = 0
End If
sPos = cPos + 1
lPos = cPos
Loop
MsgBox output
End Sub

[giacomo]

I tested this on a couple different data sets and this worked for me...

Sub fcn()
Dim intArray(), index, char As Integer
Dim strIn, strOut As String

index = 1
comma = 1
char = 1
strIn = ActiveCell.Value & ","

Do
ReDim Preserve intArray(index)
comma = InStr(char, strIn, ",", 0)
intArray(index) = Int(Mid(strIn, char, (comma - char)))
char = comma + 1
index = index + 1
Loop While InStr(char, strIn, ",", 0) > 0

strOut = "" & intArray(1)

For index = 2 To UBound(intArray)
If intArray(index) <> intArray(index - 1) + 1 Then
strOut = strOut & "," & intArray(index)
Else
If index <> UBound(intArray) Then
If intArray(index) <> intArray(index + 1) - 1 Then
strOut = strOut & "-" & intArray(index)
End If
Else
strOut = strOut & "-" & intArray(index)
End If
End If
Next index
MsgBox (strOut)
End Sub

[ This Message was edited by: giacomo on 2002-04-30 20:53 ]

[Tom Schreiner]

I tested giacomo's code and it works nicely.
Tom

[waderw]

I appreciate it. I'll let you know how it turns out.

Regards,

[waderw]

Well, I decided to let Excel do some of the work for me since I was under a little bit of a time constraint to have this completed. I used the "Text to Data" function then sorted the selection ascending. The rest of the code is to compare numbers to find ranges(if any).
The code is a little sloppy right now. I need to clean it up a little.

Function FindRanges()
Dim WorkCell, LastCell, SortedList As String
Dim ColCount, NumList As Integer
Dim Lo, temp, ConsecTemp As Integer
Dim isConsec As Boolean

WorkCell = ActiveCell.Offset(12, 15).Address
isConsec = False

Do Until ActiveCell = vbNullString
LastCell = ActiveCell.Address
Application.DisplayAlerts = False
Selection.TextToColumns Destination:=Range(WorkCell), DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
Application.DisplayAlerts = True
ActiveCell.Value = vbNullString
Range(WorkCell).Select
Range(ActiveCell, Selection.End(xlToRight).Address).Select 'sort
Selection.Sort Key1:=Range(WorkCell), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight ', DataOption1:=xlSortNormal
NumList = Selection.Columns.count
Range(WorkCell).Select
SortedList = ActiveCell.Value

For ColCount = 1 To NumList
Lo = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
temp = ActiveCell.Value
If isConsec And temp = vbNullString Then
SortedList = SortedList & "-" & ConsecTemp
isConsec = False
Range(WorkCell, Selection.End(xlToRight).Address).Select
Selection.Clear
Exit For
ElseIf temp = vbNullString Then
Range(WorkCell, Selection.End(xlToRight).Address).Select
Selection.Clear
Exit For
ElseIf (Lo + 1) = temp Then
ConsecTemp = temp
isConsec = True
ElseIf (Lo + 1) <> temp And isConsec Then
SortedList = SortedList & "-" & Lo & ", " & temp
isConsec = False
Else
SortedList = SortedList & "," & temp
End If
Next

Range(LastCell).Select
ActiveCell = SortedList
Lo = vbNullString
temp = vbNullString
ConsecTemp = 0
SortedList = vbNullString
ActiveCell.Offset(1, 0).Select
Loop
End Function

let me know if you have any suggestions or thoughts.

Regards,
Robert