# How to group consecutive and non consecutive phone numbers

#### traveler84

##### New Member
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?

### Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

#### CephasOz

##### Board Regular
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.

VBA Code:
``````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

##### Board Regular
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:
VBA Code:
``````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:

Last edited:

#### Peter_SSs

##### MrExcel MVP, Moderator
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.

VBA Code:
``````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

##### MrExcel MVP, Moderator
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
ABCD
1Example:GroupsHelper
2555000000055500000005550000000
355500011115550001111-55500011125550001111
455500011125550001114-55500011152
555500011145550001118-55500011255550001114
655500011155550001133-55500011343
7555000111855500011385550001118
855500011195550001141-5550001142
955500011205550001144
105550001121
115550001122
125550001123
135550001124
1455500011254
1555500011335550001133
1655500011345
1755500011385550001138
1855500011415550001141
1955500011427
2055500011445550001144
210
220
Phone Numbers (2)
Cell Formulas
RangeFormula
B2:B20B2=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:D22D2=IF(A2<>N(A1)+1,A2,IF(A2=A3-1,"",COUNTIF(D\$1:D1,">1000")))

#### traveler84

##### New Member
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

##### New Member
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:

VBA Code:
``5551110000-5551110010``
to have an output like

VBA Code:
``5551110000-0010``
Basically the last 4 of the TN that range. I can easily use

Code:
``=IF(B2="","",CONCATENATE(MID(B2,1,10),"-",MID(B2,18,4)))``
Which returns:

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

VBA Code:
``````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

##### New Member
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.

VBA Code:
``````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:

VBA Code:
``5551110000-0010``

#### traveler84

##### New Member
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.

VBA Code:
``````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

##### New Member
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:

VBA Code:
``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.

VBA Code:
``````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``````

Threads
1,089,638
Messages
5,409,474
Members
403,265
Latest member
HMR120