Compress consecutive numbers

[keda duck]

1. Column A data is an indefinite length text (within 100 characters) composed of any natural number, ensuring that any number in the text is greater than the preceding number;
2. Compress consecutive numbers, such as 1, 2, 3, 4 in A2, which are consecutive numbers and compressed into 1-4, 11, 12 in A2, which are consecutive numbers and compressed into 11-12, and so on. The final result is shown in B2;
3. If there are consecutive odd or even numbers, they should also be compressed, with consecutive odd numbers marked as single and consecutive even numbers marked as double
Note: Consider 3 first and then consider 2, as shown in rows 6-7

text.xlsx
	A	B
1	source	result
2	1,2,3,4,8,11,12,16,17,18	1-4,8,11-12,16-18
3	3,5,6,7,9,12,13,14,15,20,101	3,5-7,9,12-15,20,101
4	1,3,5,7,9,11	1-11(single)
5	1	1
6	2,4,6,8,10,12,14,16,17	2-16(double),17
7	1,5,6,7,9,12,13,14,15,16	1,5-6,7-9(single),12-16
8	2,3,4,5,6,7,10,17,22,23,24,25,26,77	2-7,10,17,22-26,77
9	3,4,7,13,15,16,17	3-4,7,13-15(single),16-17
10	1,2,3,4,5,6,7,13,15,17	1-7,13-17(single)
11	3,5,7,13,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80	3-7(single),13,22-80(double)
12	2,3,4,7,12,14,17,18	2-4,7,12-14(double),17-18
Sheet9

PS:This question came to me based on the schedule of a certain university. I saw several pieces of information in one cell of the schedule: course/week/location/teacher/composition of teaching class/number of course takers, and there may be multiple courses.
The format of the week is very similar to this data source. One cell is written as (3-4 sections) 2-8 weeks, 12-14 weeks (double), 15-17 weeks, and the label "single double" after it refers to attending classes in a single or double week.
When I saw this schedule, I thought it was similar to the problems I had done before, but with some differences. Therefore, I will simplify it and show it to everyone. I hope to use functions to solve it.

 

[Macropod]

See the ParseNumSeq function at: Microsoft Office Forums - View Single Post - [Solved] Changing 1,2,3,15 to 1-3,15. Although written for Word, it will work exactly the same for Excel. All you need is call it from an Excel macro referencing the cell to be modified.

 

[keda duck]

See the ParseNumSeq function at: Microsoft Office Forums - View Single Post - [Solved] Changing 1,2,3,15 to 1-3,15. Although written for Word, it will work exactly the same for Excel. All you need is call it from an Excel macro referencing the cell to be modified.

I looked at this website and it doesn't seem to solve the problem of compressing consecutive odd and even numbers

 

[Macropod]

And how is any code supposed to differentiate between broken sequences of odd or even numbers interspersed with other unbroken odd or even number sequences? Consider your example 7. How is a macro supposed to know you want 7-9 and not 7,9? What rule determines that? The same goes for examples 9 -12.

If all you have a sequence of odd or even numbers you want to process, some simple math can be done on the string before passing it to the function. For example, add 1 to the odd numbers, then divide by 2, or simply divide even numbers by 2.

For mixed strings, you'll need to develop some logic for parsing their different parts before passing the parts to the function and recombining the output afterwards.

The code I directed you to deals with the central issue.

 

[keda duck]

And how is any code supposed to differentiate between broken sequences of odd or even numbers interspersed with other unbroken odd or even number sequences? Consider your example 7. How is a macro supposed to know you want 7-9 and not 7,9? What rule determines that? The same goes for examples 9 -12.

If all you have a sequence of odd or even numbers you want to process, some simple math can be done on the string before passing it to the function. For example, add 1 to the odd numbers, then divide by 2, or simply divide even numbers by 2.

For mixed strings, you'll need to develop some logic for parsing their different parts before passing the parts to the function and recombining the output afterwards.

The code I directed you to deals with the central issue.

This is the schedule of a certain university. I saw several pieces of information in one cell of the schedule: courses/week/location/teacher/composition of teaching classes/number of selected courses, and there may be multiple courses. The exported data format is like this, for example (3-4 classes) 2-8 weeks, 12-14 weeks (double), 15-17 weeks, and the label "single double" after it refers to odd or even weeks of classes. In terms of character length, 12,14 should not be compressed into 12-14 weeks (double). I think exporting this format is because it is more convenient for programming and does not require considering many situations.

The code should prioritize distinguishing between unbroken odd or even sequences before compressing unbroken continuous numbers. Therefore, Example 7 should compress 7,9 into 7-9 (single), and then compress 5,6,12,13,14,15,16 into 5-6, 12-13
The same principle applies to 3, 4, 7, 13, 15, 16, and 17, as the code should prioritize distinguishing between unbroken odd or even sequences before compressing unbroken continuous numbers. Therefore, 13 and 15 are compressed into 13-15 (single), and 3, 4, 16, and 17 are compressed into 3-4, 16-17

 

[kvsrinivasamurthy]

Does VBA code (macro) will do.

 

[keda duck]

b3=3-5(single),6,7-9(single),12-15,20,101. It is my fault...

 

[Macropod]

Try adding the following code to an ordinary code module in your workbook

Option Explicit

Public Function RoomList(Source As Range) As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
RoomList = ParseNumSeq(Source.Text)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function

Function ParseNumSeq(StrNums As String)
Dim ArrTmpA(), ArrTmpB(), i As Long, j As Long
ReDim ArrTmpA(UBound(Split(StrNums, ","))): ReDim ArrTmpB(UBound(Split(StrNums, ",")))
For i = 0 To UBound(Split(StrNums, ","))
  ArrTmpA(i) = CLng(Split(StrNums, ",")(i))
Next
ArrTmpB(0) = ArrTmpA(0): ArrTmpB(UBound(ArrTmpB)) = ArrTmpA(UBound(ArrTmpA))
'Process large odd/even sequences
For i = 1 To UBound(ArrTmpA) - 1
  If ArrTmpA(i) = ArrTmpA(i - 1) + 2 And ArrTmpA(i + 1) - 2 = ArrTmpA(i) Then
    ArrTmpB(i) = "-"
  Else
    ArrTmpB(i) = CLng(ArrTmpA(i))
  End If
Next
StrNums = Join(ArrTmpB, ",")
While InStr(StrNums, ",-,-")
  StrNums = Replace(StrNums, ",-,-", ",-")
Wend
StrNums = Replace(StrNums, ",-,", "-")
ReDim ArrTmpA(UBound(Split(StrNums, ","))): ReDim ArrTmpB(UBound(Split(StrNums, ",")))
'Process large single sequences
For i = 0 To UBound(Split(StrNums, ","))
  If IsNumeric(Split(StrNums, ",")(i)) Then
    ArrTmpA(i) = CLng(Split(StrNums, ",")(i))
  Else
    ArrTmpA(i) = Split(StrNums, ",")(i)
  End If
Next
ArrTmpB(0) = ArrTmpA(0): ArrTmpB(UBound(ArrTmpB)) = ArrTmpA(UBound(ArrTmpA))
For i = 1 To UBound(ArrTmpA) - 1
  If IsNumeric(ArrTmpA(i - 1)) And IsNumeric(ArrTmpA(i)) And IsNumeric(ArrTmpA(i + 1)) Then
    If ArrTmpA(i) = ArrTmpA(i - 1) + 1 And ArrTmpA(i + 1) - 1 = ArrTmpA(i) Then
      ArrTmpB(i) = "-"
    Else
      ArrTmpB(i) = CLng(ArrTmpA(i))
    End If
  Else
    ArrTmpB(i) = ArrTmpA(i)
  End If
Next
StrNums = Join(ArrTmpB, ",")
While InStr(StrNums, ",-,-")
  StrNums = Replace(StrNums, ",-,-", ",-")
Wend
StrNums = Replace(StrNums, ",-,", "-")
'Process short sequences
For i = UBound(Split(StrNums, ",")) - 1 To 1 Step -1
  If IsNumeric(Split(StrNums, ",")(i)) And IsNumeric(Split(StrNums, ",")(i + 1)) Then
    Select Case Split(StrNums, ",")(i + 1) - Split(StrNums, ",")(i)
    Case 1, 2
      StrNums = Replace(StrNums, Split(StrNums, ",")(i) & "," & Split(StrNums, ",")(i + 1), Split(StrNums, ",")(i) & "-" & Split(StrNums, ",")(i + 1))
    End Select
  End If
Next
ParseNumSeq = StrNums
End Function

To use the function, just insert a formula like:
=roomlist(A1)
in the cell where you want the output to appear.

If you don't want a custom formula, you can just call the ParseNumSeq function with a macro that loops through the cells to be processed.

 

[Fuji]

UDF
Use like
=CompNums(A2,",")

Function CompNums(ByVal txt$, ByVal delim$)
    Dim x, i&, ii&, myStep&, a(1 To 2), s$, temp&
    If txt = "" Then CompNums = "": Exit Function
    x = Evaluate("{" & txt & ",true}")
    If UBound(x) = 2 Then CompNums = x(1): Exit Function
    For i = 1 To UBound(x) - 1
        myStep = x(i + 1) - x(i)
        If myStep = 2 Then
            a(1) = x(i): ii = 1: a(2) = a(1)
            For ii = i + 1 To UBound(x)
                If x(ii) - a(2) <> myStep Then Exit For
                a(2) = x(ii): x(ii) = False
            Next
            x(i) = Join(a, "-")
            If myStep = 2 Then
                x(i) = x(i) & "(single)"
            ElseIf myStep = 3 Then
                x(i) = x(i) & "(double)"
            End If
            i = ii - 1
        End If
    Next
    x = Filter(x, False, 0)
    If UBound(x) = 1 Then
        CompNums = x(1)
    Else
        For i = 0 To UBound(x)
            If Not x(i) Like "*-*" Then
                a(1) = x(i): a(2) = "": temp = Val(x(i))
                For ii = i + 1 To UBound(x)
                    If x(ii) Like "*-*" Then Exit For
                    If Val(x(ii)) - temp = 1 Then
                        a(2) = x(ii): temp = Val(x(ii)): x(ii) = False
                    End If
                Next
                x(i) = a(1) & IIf(a(2) <> "", "-" & a(2), "")
            End If
        Next
    End If
    x = Filter(x, False, 0)
    ReDim Preserve x(UBound(x) - 1)
    CompNums = Join(x, ",")
End Function

Got

myStep.xlsm
	A	B	C	D
1	source	result		result
2	1,2,3,4,8,11,12,16,17,18	1-4,8,11-12,16-18		1-4,8,11-12,16-18
3	3,5,6,7,9,12,13,14,15,20,101	3-5(single),6,7-9(single),12-15,20,101		3-5(single),6,7-9(single),12-15,20,101
4	1,3,5,7,9,11	1-11(single)		1-11(single)
5	1	1		1
6	2,4,6,8,10,12,14,16,17	2-16(single),17		2-16(double),17
7	1,5,6,7,9,12,13,14,15,16	1,5-6,7-9(single),12-16		1,5-6,7-9(single),12-16
8	2,3,4,5,6,7,10,17,22,23,24,25,26,77	2-7,10,17,22-26,77		2-7,10,17,22-26,77
9	3,4,7,13,15,16,17	3-4,7,13-15(single),16-17		3-4,7,13-15(single),16-17
10	1,2,3,4,5,6,7,13,15,17	1-7,13-17(single)		1-7,13-17(single)
11	3,5,7,13,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80	3-7(single),13,22-80(single)		3-7(single),13,22-80(double)
12	2,3,4,7,12,14,17,18	2-4,7,12-14(single),17-18		2-4,7,12-14(double),17-18
Sheet1

Cell Formulas
Range	Formula
B2:B12	B2	=CompNums(A2,",")

 

[Fuji]

Correction;

            If myStep = 2 Then
                x(i) = x(i) & "(single)"
            ElseIf myStep = 3 Then
                x(i) = x(i) & "(double)"
            End If

to

            If a(1) Mod 2 <> 0 Then
                x(i) = x(i) & "(single)"
            Else
                x(i) = x(i) & "(double)"
            End If

to get

myStep.xlsm
	A	B	C
1	source	result	result
2	1,2,3,4,8,11,12,16,17,18	1-4,8,11-12,16-18	1-4,8,11-12,16-18
3	3,5,6,7,9,12,13,14,15,20,101	3-5(single),6,7-9(single),12-15,20,101	3-5(single),6,7-9(single),12-15,20,101
4	1,3,5,7,9,11	1-11(single)	1-11(single)
5	1	1	1
6	2,4,6,8,10,12,14,16,17	2-16(double),17	2-16(double),17
7	1,5,6,7,9,12,13,14,15,16	1,5-6,7-9(single),12-16	1,5-6,7-9(single),12-16
8	2,3,4,5,6,7,10,17,22,23,24,25,26,77	2-7,10,17,22-26,77	2-7,10,17,22-26,77
9	3,4,7,13,15,16,17	3-4,7,13-15(single),16-17	3-4,7,13-15(single),16-17
10	1,2,3,4,5,6,7,13,15,17	1-7,13-17(single)	1-7,13-17(single)
11	3,5,7,13,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80	3-7(single),13,22-80(double)	3-7(single),13,22-80(double)
12	2,3,4,7,12,14,17,18	2-4,7,12-14(double),17-18	2-4,7,12-14(double),17-18
Sheet1

Cell Formulas
Range	Formula
B2:B12	B2	=CompNums(A2,",")