How to group consecutive and non consecutive phone numbers

traveler84

New Member
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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?
 

Some videos you may like

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
Joined
Feb 18, 2020
Messages
55
Office Version
365, 2016
Platform
Windows
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
Joined
Apr 19, 2008
Messages
161
Office Version
365, 2019
Platform
Windows
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:
1124528.gif
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
43,527
Office Version
365
Platform
Windows
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
Joined
May 28, 2005
Messages
43,527
Office Version
365
Platform
Windows
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
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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
Joined
Feb 17, 2020
Messages
8
Office Version
365, 2016
Platform
Windows
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
 

Forum statistics

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

This Week's Hot Topics

Top