Formatting of Telephone numbers

[jonnyscott]

Hi there guys,
Really hoping someone might be able to help me here. I know there have been questions about Telephone numbers before, but I haven't found any that have the issue that I've got.

I have a number of records on phone numbers (around 3500), I know that it is possible to format the cells with Custom formats etc, however I have the phone numbers in various lengths some 7 digits, some 8, etc and I want to try and standardize it all to the same format.

The reason for the different lengths varies depending on who put them into the sheet,
Some records have country at the start eg +64 some of which are missing the +,
Some records have no country code but have the area code of the city, eg. 03, or 04 (some of which are missing the 0)

There is also at the end of some of these cells the extension number for the person, this too has also been put in by various people with different formats, eg. ext, extn, Ext, x, Ext. and Extn: however I've sorted this using a macro to change these all to just be Ext:

Example:
35551234
035551234
(03) 555 1234, Ext: 5678
+64 3 555 1234
+643 555 1234
+643 5551234, Ext: 567
03 555 1234
03 555-1234
03 684 4129
03-5551234
03-555-1234, Ext: 5678
64 3 555 1234, Ext: 567

As you can see there are a number of different formats, and as I've also mentioned, some of these may or may not be followed by , Ext: and their extension number
These above I think are the majority of the problems

I have a VBA script that goes through and converts all the wrong extension related stuff to the way I want it, and I have tried to get it.

However I'm a bit stuck for when I want it to change the area code to add the Zero in front or adding a + at the start, as well as the spaces in the wrong place, Ideally I would like things in the following format

I've found that with the cells that contain text as well, that the leading zero stays, however the cells that don't have text as part of them loose the leading Zero.

+64 3 555 1234, Ext: 5678

If someone could help me out here it would be appreciated. The code I have at the moment is as follows, note that the Colomn H is the colomn that has all the telephone numbers, and yes I know there is probably a much better way for doing all this, if so, please let me know.

Private Sub Worksheet_Activate()
Range("A1:K5001").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False

'Begin Changing Telephone numbers
Columns("H:H").Select

'Remove all Gaps
'First one to replace Dash used to represent Extensions
Selection.Replace What:=" - ", Replacement:=" Ext: ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Replace X used for extension before spaces removed
Selection.Replace What:=" x ", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Change front of phone number
Selection.Replace What:="+64", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(0", Replacement:="+64 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'Standardise Extension
Selection.Replace What:="Ext:", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="ext.", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="ext", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="extn:", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="extn", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Standardise Ext to Ext:
Selection.Replace What:="orExt", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=",Ext", Replacement:="Ext", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Ext", Replacement:=", Ext: ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Range("B2").Select
Range("A1").Select
End Sub

 

[mikerickson]

If you put the number 6435551234.5678 in a cell with the custom format
"+"00 0 000 0000", Ext".#### it will show +64 3 555 1234, Ext.5678

 

[jonnyscott]

Thanks Mike, appreciate that, the problem now is getting all the fields to make sure they have 64 at the front.

 

[jonnyscott]

Actually I've just remembered, I was really wanting to get this in some kind of way for a VBA Script, although your idea is great and will work to some degree I'm also stuck at getting to make sure 64 is at the front of all the cells.

 

[mikerickson]

Perhaps

Sub test()
    Dim rawNumeral As String
    Dim resultString As String
    Dim resultNumber As Double
    Dim resultArray As Variant
    Dim i As Long, j As Long
    Dim cellsTochange As Range
    Dim lastRow As Long
    
    With Sheet1.Range("H:H")
        MsgBox .Cells(.Rows.Count, 1).End(xlUp).Row
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        resultArray = .Cells(1, 1).Resize(lastRow, 1).Value
    
    For i = 1 To lastRow
        rawNumeral = CStr(.Cells(i, 1).Value)

        If 0 < InStr(1, LCase(rawNumeral), "ext") Then
            rawNumeral = LCase(Replace(rawNumeral, ".", vbNullString))
            rawNumeral = Replace(rawNumeral, "ext", ".")
        End If
        
        For j = 1 To Len(rawNumeral)
            If Mid(rawNumeral, i, 1) Like "[0-9.]" Then
                resultString = resultString & Mid(rawNumeral, i, 1)
            End If
        Next j
        
        If Not (resultString Like "64*") Then resultString = "64" & resultString
        resultNumber = Val(resultString)
        
        resultString = Format(resultNumber, """+""00 0 000 0000"", Ext"".####")
        resultArray(i, 1) = resultNumber
    Next i
        With .Cells(1, 1).Resize(lastRow, 1)
            .Value = resultArray
            .NumberFormat = """+""00 0 000 0000"", Ext"".####"
        End With
    End With
End Sub

 

[jonnyscott]

Thanks again, however that one seems to overwrite all the fields with "+00 0 000 0064 Ext."

I think what I'm going to have to do as one thing I forgot to mention is that I'm actually going to want these as text and not formatted (this is so I can copy the text out in the same format and put it elsewhere with the same formatting).
I'll probably have to strip all the text out (replacing the Ext with a . like you have previously mentioned),

Strip out the leading zero or 64 if they exist, this should give me the area code and phone number along with extension number if exists.

eg. 35551234.5678

However I've got to work out how to get the VBA script to use something like an if statement to say, if the first characher is a zero OR the first two are a 64 then remove.

To complicate things more, I also have one set of numbers which need to keep a leading 0 and not add the 64, these are the toll free numbers, so would need to be 0800, So I guess I need the formula to check the first two characters for a 08.

Appreciate anyones help on this. I slept on it and realised that I should have mentioned this too.

Thanks for your help.