Find consecutive number ranges

[Neliz]

Hi all,

I can't figure out how to solve next issue, hope someone can help me.

From a database I get (for example) next numbers (could be 1 or several numbers aswell):

1700103735
1700103736
1700103737
1700103738
1700103739
1700103740
1700103741
1700103743
1700103745
1700103746
1700103747
1700103748
1700103749

<tbody>
</tbody><colgroup><col></colgroup>

How can I easely make a consecutive number range in (for example) B2?
Outcome needs to be (in one cell): 1700103735/1700103741, 1700103743, 1700103745/1700103749

Many thaks for your feedback!

 

[Special-K99]

VBA or formula solution?

 

[Neliz]

I prefer VBA

 

[Special-K99]

I'm no expert at VBA.

 

[JumpingCrab]

Try this, assuming your data is in A2:A14

Public Sub ConCat1()
    Dim InputRange As Range
    Dim Streak As Boolean
    Dim NumberRange As String
    Dim FirstConsecutiveNumber As Long
    Dim ThisRow As Long
    Dim NrOfRows As Long
    
    Set InputRange = Range("A2:A14")
    NrOfRows = InputRange.Rows.Count
    
    
    NumberRange = InputRange(1, 1)
    FirstConsecutiveNumber = InputRange(1, 1)
    Streak = False
    
    For ThisRow = 2 To InputRange.Rows.Count
        If InputRange(ThisRow, 1) - InputRange(ThisRow - 1, 1) <> 1 Then 'we lost our streak
            If Streak = True Then
                NumberRange = NumberRange & "/" & Trim(InputRange(ThisRow - 1, 1))
            End If
                NumberRange = NumberRange & ", " & Trim(InputRange(ThisRow, 1))
            
            FirstConsecutiveNumber = InputRange(ThisRow, 1)
            Streak = False
        Else
            Streak = True
            If ThisRow = NrOfRows Then
                NumberRange = NumberRange & "/" & Trim(InputRange(ThisRow, 1))
            End If
        End If
    Next ThisRow
    
    Range("B2") = NumberRange
End Sub

Hope this helps
JL

 

[JumpingCrab]

Try this, assuming your data is in A2:A14

Public Sub ConCat1()
    Dim InputRange As Range
    Dim Streak As Boolean
    Dim NumberRange As String
    Dim FirstConsecutiveNumber As Long
    Dim ThisRow As Long
    Dim NrOfRows As Long
    
    Set InputRange = Range("A2:A14")
    NrOfRows = InputRange.Rows.Count
    
    
    NumberRange = InputRange(1, 1)
    FirstConsecutiveNumber = InputRange(1, 1)
    Streak = False
    
    For ThisRow = 2 To InputRange.Rows.Count
        If InputRange(ThisRow, 1) - InputRange(ThisRow - 1, 1) <> 1 Then 'we lost our streak
            If Streak = True Then
                NumberRange = NumberRange & "/" & Trim(InputRange(ThisRow - 1, 1))
            End If
            NumberRange = NumberRange & ", " & Trim(InputRange(ThisRow, 1))
            FirstConsecutiveNumber = InputRange(ThisRow, 1)
            Streak = False
        Else    ' We have a streak
            Streak = True
            If ThisRow = NrOfRows Then   ' write out the last number
                NumberRange = NumberRange & "/" & Trim(InputRange(ThisRow, 1))
            End If
        End If
    Next ThisRow
    
    Range("B2") = NumberRange
End Sub

Hope this helps.
JL

 

[Marcelo Branco]

Another...

Sub aTest()
    'Assumes data in column A beginning in row 2
    Dim vData As Variant, i As Long, currMin As String, currMax As String
    Dim strResult As String
       
    vData = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
    currMin = vData(1, 1)
    currMax = vData(1, 1)
    
    For i = LBound(vData) + 1 To UBound(vData)
        If vData(i, 1) = vData(i - 1, 1) + 1 Then
            currMax = vData(i, 1)
        Else
            If currMin = currMax Then
                strResult = strResult & ", " & currMin
            Else
                strResult = strResult & ", " & currMin & "/" & currMax
            End If
            currMin = vData(i, 1)
            currMax = vData(i, 1)
        End If
    Next i
    Range("B2") = Mid(strResult, 3)
End Sub

M.

 

[Rick Rothstein]

This looked like an interesting problem, so I issued a challenge to myself to see if I could do this with a one-liner UDF (user defined function). Why? Don't ask. Anyway, I was successful, but with some of provisos. First off, the UDF takes one argument... a range of contiguous vertical cells. This range cannot start on Row 1... the range must consist of two or more cells... the cell immediately before the range and the cell immediately after the range must be blank. If these conditions are met, then this UDF appears to work...

[table="width: 500"]
[tr]
	[td]Function NumRanges(Rng As Range) As String
  NumRanges = Replace(Application.Trim(Replace(Replace(Replace(Application.Trim(Replace(Join(Application.Transpose(Evaluate(Replace(Replace(Replace("IF(($+1=@)*(-=@+1),""|"",IF($+1=@,""|""&@,IF(@="""","""",@)))", "$", Rng.Offset(-1).Address), "@", Rng.Address), "-", Rng.Offset(1).Address))), ", "), ", |", " ")), " ", "/"), ",/", " "), ",", " ")), " ", ", ")
End Function[/td]
[/tr]
[/table]

HOW TO INSTALL UDFs
------------------------------------
If you are new to UDFs, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. You can now use NumRanges just like it was a built-in Excel function. For example,

=NumRanges(A2:A100)

If you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

 

[Neliz]

Thank you all for your replies, my issue has been solved!

 

[JumpingCrab]

You're welcome