```
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
```