How to group consecutive and non consecutive phone numbers

[traveler84]

Off and on for many years, I've battled an issue and I'm hoping someone might have more ridges in their brain than me.

I have a large list of phone numbers in order. What I need to do is group consecutive ranges into a format of ##########-####. Everything is standard in column A with normal formatting with no fancy codes. Literally just the phone numbers.

Example:
5550000000
5550001111
5550001112
5550001114
5550001115

Output:
5550000000
5550001111-1112
5550001114-1115


I have thousands of phone numbers that I have to find those breaks. I often cheat a little by using a =IF(A2-A1=1),"RANGE","NOT RANGE." Or I might use MID to do the same with the last 4 values depending on my flavor of the day.

My experiments:

I've figured out how to identify if a number is consecutive and flag it as such.

I have used conditional formatting, copied into WORD and back into excel, then used a VBA formula to find where each break is in the list of TNs by identifying the color code.

Issue:

I can't seem to figure out how if I say I have 5 or 50 in a range, how to output them out as such and also identify the non ranges in a list. Is there a VBA script that could help with this?

 

[CephasOz]

Try this. You may have to change the values for cdblColRange and cdblColQty if you don't want to use columns D & E, but please note that the output is into the SAME worksheet that contains the phone numbers.

Sub GroupPhoneNos()
    Const cintGroupRange As Integer = 10000         ' Phone numbers grouped in brackets of 10,000
    Const cstrFmtWholeNo As String = "0000000000"   ' Format for displaying a phone number
    Const cstrFmtPartNo As String = "0000"          ' Format for displaying part of a phone number
    Const cdblFirstRow As Double = 1                ' First row
    Const cdblFirstCol As Double = 1                ' First column
    Const cdblHeaderRow As Double = 1               ' Row used for headings
    Const cdblTopDataRow As Double = 2              ' Start of the rows of data
    Const cdblColPhoneNo As Double = 1              ' The column where phone numbers are found
    Const cdblColRange As Double = 4                ' Range goes in column D
    Const cdblColQty As Double = 5                  ' Count goes in column E
    Dim dblPhoneRow As Double                       ' For looping through phone number rows
    Dim dblLastPhoneRow As Double                   ' The last row on which a phone number occurs
    Dim dblGroupRow As Double                       ' The current row on which either the range/count or range/missing will be written
    Dim dblCurrentPhoneNo As Double                 ' The phone number on the current row of the listing
    Dim dblPrevPhoneNo As Double                    ' The phone number from the previous row
    Dim dblRangeStart As Double                     ' The phone number which starts the current group of numbers
    Dim bolOutput As Boolean                        ' Is it time to output a grouping?
    '
    With ActiveSheet
        ' Initialsie
        dblPrevPhoneNo = 0
        dblRangeStart = 0
        bolOutput = False
        ' Set headings
        .Cells(cdblHeaderRow, cdblColRange).Value = "Range"
        .Cells(cdblHeaderRow, cdblColQty).Value = "Count"
        dblGroupRow = cdblHeaderRow
        ' Process the phone numbers
        dblLastPhoneRow = .Cells(cdblFirstRow, cdblFirstCol).CurrentRegion.Rows.Count
        For dblPhoneRow = cdblTopDataRow To (dblLastPhoneRow + 1)
            dblCurrentPhoneNo = .Cells(dblPhoneRow, cdblColPhoneNo).Value
            If ((dblCurrentPhoneNo \ cintGroupRange) = (dblRangeStart \ cintGroupRange)) Then
                If (dblCurrentPhoneNo = (dblPrevPhoneNo + 1)) Then
                    bolOutput = False
                Else
                    bolOutput = True
                End If
            Else
                bolOutput = True
            End If
            ' Don't output if this is the first record
            If (dblPhoneRow = cdblTopDataRow) Then
                dblRangeStart = dblCurrentPhoneNo
                bolOutput = False
            End If
            ' Output if necessary.
            If bolOutput Then
                dblGroupRow = dblGroupRow + 1
                If (dblRangeStart = dblPrevPhoneNo) Then
                    With .Cells(dblGroupRow, cdblColRange)
                        .NumberFormat = cstrFmtWholeNo
                        .HorizontalAlignment = xlHAlignLeft
                        .Value = Format(dblRangeStart, cstrFmtWholeNo)
                    End With
                Else
                    .Cells(dblGroupRow, cdblColRange).Value = Format(dblRangeStart, cstrFmtWholeNo) & "-" & Format((dblPrevPhoneNo Mod cintGroupRange), cstrFmtPartNo)
                End If
                With .Cells(dblGroupRow, cdblColQty)
                    .HorizontalAlignment = xlHAlignLeft
                    .Value = dblPrevPhoneNo - dblRangeStart + 1
                End With
                If (dblPhoneRow <= dblLastPhoneRow) Then
                    dblGroupRow = dblGroupRow + 1
                    If ((dblPrevPhoneNo + 1) < (dblCurrentPhoneNo - 1)) Then
                        .Cells(dblGroupRow, cdblColRange).Value = Format((dblPrevPhoneNo + 1), cstrFmtWholeNo) & "-" & Format(((dblCurrentPhoneNo - 1) Mod cintGroupRange), cstrFmtPartNo)
                    Else
                        With .Cells(dblGroupRow, cdblColRange)
                            .NumberFormat = cstrFmtWholeNo
                            .HorizontalAlignment = xlHAlignLeft
                            .Value = Format((dblPrevPhoneNo + 1), cstrFmtWholeNo)
                        End With
                    End If
                    .Cells(dblGroupRow, cdblColQty).Value = "MISSING"
                End If
                dblRangeStart = dblCurrentPhoneNo
            End If
            ' Copy current to last phone no
            dblPrevPhoneNo = dblCurrentPhoneNo
        Next
        .Cells(cdblHeaderRow, cdblColRange).CurrentRegion.Columns.AutoFit
    End With
End Sub

 

[kennypete]

There may well be some crazy amazing way to do this with formulas, which seems to happen moments after I post sometimes, but nonetheless the following VBA routine achieves it:

Option Explicit
Sub GroupConsecutivePhoneNumbers()

Dim colN As New Collection
Dim dicG As Object
Dim dblN As Double
Dim lngR As Long

Set dicG = CreateObject("Scripting.Dictionary")
dblN = 0

' Build the dicG dictionary
For lngR = Range("A:A").CurrentRegion.Count To 1 Step -1
    If lngR > 1 Then
        dblN = Cells(lngR - 1, 1)
        If Cells(lngR, 1) = dblN + 1 Then
            colN.Add Cells(lngR, 1)
        Else
            dicG.Add CStr(Cells(lngR, 1)), ""
            If colN.Count > 0 Then
                dicG.Remove CStr(Cells(lngR, 1))
                dicG.Add CStr(Cells(lngR, 1)), "-" & Right(CStr(colN(1)), 4)
            End If
            Set colN = New Collection
        End If
    Else
        dicG.Add CStr(Cells(lngR, 1)), ""  ' *** NB: does not handle if (A1 = A2 - 1)  ***
    End If
Next

' Reverse the order of the dictionary into the recycled collection and output it
Set colN = New Collection
Dim key As Variant
For Each key In dicG
    If colN.Count = 0 Then
        colN.Add key & dicG(key)
    Else
        colN.Add key & dicG(key), Before:=1
    End If
Next
For lngR = 1 To colN.Count
    Cells(lngR, 3) = colN(lngR)
Next

End Sub

Some caveats:
1. Numbers must be in column A and start at A1 with nothing else following them in column, and
2. As noted in the commented code, A1 mustn't be 1 less than A2 (e.g. your example it is much less).
These things could be handled, but I expect its the concept your after.

Running on my test file:

 

[Peter_SSs]

Is there a VBA script that could help with this?

Welcome to the MrExcel board!

Assuming that original data is in column A, with the first phone number in row 2, try this with a copy of your data.

Sub Group_Numbers()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 2 To UBound(a)
    If a(i, 1) <> Val(a(i - 1, 1)) + 1 Then
      k = k + 1
      b(k, 1) = a(i, 1)
    Else
      b(k, 1) = Split(b(k, 1), "-")(0) & -a(i, 1)
    End If
  Next i
  Range("B2").Resize(k).Value = b
End Sub

 

[Peter_SSs]

If you want a formula approach, here is one way using a helper column (that could be hidden once the formulas have been entered in it).

A_MrExcel.xlsm
	A	B	C	D
1	Example:	Groups		Helper
2	5550000000	5550000000		5550000000
3	5550001111	5550001111-5550001112		5550001111
4	5550001112	5550001114-5550001115		2
5	5550001114	5550001118-5550001125		5550001114
6	5550001115	5550001133-5550001134		3
7	5550001118	5550001138		5550001118
8	5550001119	5550001141-5550001142
9	5550001120	5550001144
10	5550001121
11	5550001122
12	5550001123
13	5550001124
14	5550001125			4
15	5550001133			5550001133
16	5550001134			5
17	5550001138			5550001138
18	5550001141			5550001141
19	5550001142			7
20	5550001144			5550001144
21				0
22				0
Phone Numbers (2)

Cell Formulas
Range	Formula
B2:B20	B2	=IFERROR(AGGREGATE(15,6,D$2:D$100/(D$2:D$100>1000),ROWS(B$2:B2))&IF(COUNTIF(D$2:D$100,ROWS(B$2:B2)),-INDEX(A$2:A$100,MATCH(ROWS(B$2:B2),D$2:D$100,0)),""),"")
D2:D22	D2	=IF(A2<>N(A1)+1,A2,IF(A2=A3-1,"",COUNTIF(D$1:D1,">1000")))

 

[traveler84]

I am humbly appreciative of all the answers. I am working on testing them out now. I like there are VBA and formula options to do the job.

 

[traveler84]

I used @Peter_SSs VBA code and was able to get it to work and saved the formula code as a backup should the shared sheet VBA stop working.I tested on a large range of TNs and it appeared to have worked with both. Thank you!

Side question, I didn't want to ask initially because I was worried about asking for too much. Is there a way to instead of having a TN like:

5551110000-5551110010

to have an output like

5551110000-0010

Basically the last 4 of the TN that range. I can easily use

=IF(B2="","",CONCATENATE(MID(B2,1,10),"-",MID(B2,18,4)))

Which returns:

5551110000-0010

I am completely okay with a separate VBA code for ease of troubleshooting later. Currently, my button has:

Private Sub CommandButton1_Click()
Remove_Dashes
Group_Numbers
End Sub

So I can just add another Sub to it to make it easier for troubleshooting later.

 

[traveler84]

In a good faith attempt to try to solve my problem, I found half the solution but I am not sure on how to exactly do the infinity loop.

Sub Fixtnformat()
Dim Result As String
Dim First As String
Dim Last As String
First = Mid(Range("B2"), 1, 10) & "-"
Last = Mid(Range("B2"), 18, 4)
Range("C2") = First & Last
End Sub

Outputs in C2 Only:

5551110000-0010

 

[traveler84]

Update

This code made more sense because the dash was already in the cell. Just added 11 characters. I tested a cell with only a single TN of ########## and it outputted correctly. Since the outputs are variable, I am going to see if while I wait to work on a loop using the interwebs and previous examples above to see if I can Frankenstein something too.

Sub Fixtnformat()
Dim Result As String
Dim First As String
Dim Last As String
First = Mid(Range("B7"), 1, 11)
Last = Mid(Range("B7"), 18, 4)
Range("C7") = First & Last
End Sub

 

[traveler84]

Okay, I'm probably being annoying at this point... but I figured out the loop!!!! I am only now stuck with trying to figure out this last part now:

For i = 1 to 500

How can I make this to the last value in Column B? Since the value can change depending on the TN quantity, I am curious to figure out a way to make it a variable number based on the last cell. I tried the xlup but cannot seem to make it work right.

Sub Fixtnformat()
Dim First As String
Dim Lastfour As String

Dim i As Integer

    For i = 1 To 500
    First = Mid(Range("B0" & i), 1, 11)
    Lastfour = Mid(Range("B0" & i), 18, 4)
    ActiveSheet.Range("C" & i).Value = First & Lastfour
    Next i
  
    
 
End Sub