Tách số điện thoại và chuyển đổi đầu số với EXCEL

[HeSanbi]

Chuyển đổi và lấy số điện thoại từ số cũ hoặc từ chuỗi số hợp lệ (giai đoạn năm 2018 đến nay)
với Hàm PhoneVN
Sẽ trả lại mảng chứa kết quả chuyển đổi và tìm số điện thoại trong chuỗi gồm các cột: Đánh thứ tự, số mới, số cũ, định dạng tiêu chuẩn, nhà mạng, chuỗi không hợp lệ

Hướng dẫn sử dụng hàm:
=PhoneVN([Số/Danh_sách],[Đối_số_cài_đặt]

Hàm cài đặt		Chức năng	Nhập đối số
=epDelimiter(",")		Ký tự nối chuỗi nếu nhiều số cùng chuỗi	Char(10) - Mặc định là dấu phẩy (,)
=epIncludeInvalid()		Trả về kết quả gồm chuỗi không hợp lệ	TRUE - Mặc định FALSE
=epExpand		Mở rộng xuống hàng mới nếu chuỗi có nhiều số ĐT	TRUE - Mặc định FALSE
=epZeroFrontNumber		Giữ lại số 0 khi in mảng	TRUE - Mặc định FALSE
=epHeader		Mảng có đầu đề hay không	TRUE - Mặc định FALSE
=epColumns(1,2,3,4,5,6)	1​	Đặt vị trí cột, nếu có cột số thứ tự	1 (Giải thích: Đánh số thứ tự sẽ nằm ở cột 1)
	2​	Đặt vị trí cột, nếu có cột số điện thoại mới	2 (Nếu không thì để 0 hoặc không đặt)
	3​	Đặt vị trí cột, nếu có cột số điện thoại cũ	3 (Mặc định tất cả cột đều là 0)
	4​	Đặt vị trí cột, nếu có cột chuẩn hóa số Điện thoại (E164)	4
	5​	Đặt vị trí cột, nếu có cột tên Nhà Mạng	5
	6​	Đặt vị trí cột, nếu có cột chuỗi không hợp lệ	6

Có hai tệp dưới gồm:
HomePhoneVN.xlsm là tệp tách và chuyển đổi số điện thoại cố định, và các số tổng đài.
MobilePhoneVN.xlsm là tệp tách và chuyển đổi số điện thoại di động.

Tệp ví dụ và mã sẽ được cập nhật tại Github:

GitHub - SanbiVN/MobilePhoneVN: Chuyển đổi và tách số điện thoại từ số cũ hoặc từ chuỗi số hợp lệ (Từ năm 2018)

Chuyển đổi và tách số điện thoại từ số cũ hoặc từ chuỗi số hợp lệ (Từ năm 2018) - GitHub - SanbiVN/MobilePhoneVN: Chuyển đổi và tách số điện thoại từ số cũ hoặc từ chuỗi số hợp lệ (Từ năm 2018)

github.com

' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\
Option Explicit
Option Compare Text
Private Const ProjectUDFName = "ConvertPhoneVN"
Private Const ProjectUDFFileName = "MobilePhoneVN"
Private Const projectUDFVersion = "2.0"

#If VBA7 Then
#Else
  Private Enum LongLong:[_]:End Enum
  #If Win64 Then
  '#ElseIf Win32 Then
  #Else
    Private Enum LongPtr:[_]:End Enum
  #End If
#End If
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Public Enum UDFNavigation
  UDFN__1 = 1
  UDFN__2
  UDFN__3
  UDFN__4
  UDFN__5
  UDFNFinally
End Enum

Public Enum ConvertPhoneSettings
  CPSMainFX = 1
  CPSResultColumns
  CPSHeader
  CPSDelimiter
  CPSincludeInvalid
  CPSExpand
  CPSZeroFrontNumber
End Enum
Private Type TypeArguments
  XLNew As Boolean
  timer As Single
  Action As UDFNavigation
  Direction As Long
  Target As Variant
  address As String
  caller As Range
  fx As String
  Delimiter As String
  includeInvalid As Boolean
  Expand As Boolean
  ZeroFrontNumber As Boolean
  Header As Boolean
 
  columns As Integer
  ReturnOrder As Integer
  OldPhoneNumber As Integer
  NewPhoneNumber As Integer
  ReturnStandardsE164 As Integer
  ReturnCompany As Integer
  ReturnInvalid As Integer
  resultArray As Variant
End Type

Private Works() As TypeArguments, ValArgs(), ValIndex As Integer
Function epDelimiter(Delimiter$): AddArguments CPSDelimiter, Delimiter: End Function
Function epincludeInvalid(): AddArguments CPSincludeInvalid: End Function
Function epExpand(): AddArguments CPSExpand: End Function
Function epZeroFrontNumber(): AddArguments CPSZeroFrontNumber: End Function
Function epHeader(): AddArguments CPSHeader: End Function
Function epColumns(Optional ReturnOrder As Integer, _
          Optional ReturnNewNumber As Integer, _
          Optional ReturnOldNumber As Integer, _
          Optional ReturnStandardsE164 As Integer, _
          Optional ReturnCompany As Integer, _
          Optional ReturnInvalid As Integer)
  AddArguments CPSResultColumns, ReturnOrder, ReturnNewNumber, ReturnOldNumber, ReturnStandardsE164, ReturnCompany, ReturnInvalid
End Function
Function PhoneVN(ParamArray arguments()) As Variant
  PhoneVN = AddArguments(CPSMainFX, arguments)
End Function

Private Function AddArguments(Direction%, ParamArray arguments()) As Variant
  On Error Resume Next
  Dim k%, i%, j%, r As Object, s$, f$, w As TypeArguments, n As Boolean, aa
  Set r = Application.ThisCell: If r Is Nothing Then Exit Function
  If r.Worksheet.ProtectContents = True Then AddArguments = "[SheetProtected]": Exit Function

  XLAppVersion n
  If n Then f = r.Formula2 Else f = r.formula
  s = r.address(0, 0, , 1)
  k = UBound(Works)
  If k > 0 Then
    For i = 1 To k
      With Works(i)
        If s = .address And f = .fx Then
          Select Case .Action
          Case UDFN__1: k = i: GoTo s
          Case UDFN__2: Exit Function
          Case UDFN__3:
            If Direction = CPSMainFX Then
              .Action = UDFNFinally: AddArguments = .resultArray: GoSub E
            End If
            Exit Function
          End Select
          Exit For
        End If
      End With
    Next
  End If
  k = k + 1
  ReDim Preserve Works(1 To k)
  With Works(k): .XLNew = n: .Action = UDFN__1: .Direction = 0: Set .caller = r: .address = s: .fx = f:
    .NewPhoneNumber = 1
    .ZeroFrontNumber = True
    .Delimiter = ","
  End With
s:
  With Works(k)
    Select Case Direction
    Case CPSMainFX:
      aa = arguments(0)
      i = 0
      k = .ReturnOrder: GoSub v
      k = .NewPhoneNumber: GoSub v
      k = .OldPhoneNumber: GoSub v
      k = .ReturnStandardsE164: GoSub v
      k = .ReturnCompany: GoSub v
      k = .ReturnInvalid: GoSub v
      .columns = i
      If IsObject(aa(0)) Then
        AddArguments = ""
        Set r = aa(0)
        If n Or (r.address = r(1, 1).address) Then aa = r.Value: GoTo r
        .Action = UDFN__2
        Set .Target = r
        .Direction = CPSMainFX
        Call SetTimer(Application.Hwnd, 21111, 0, AddressOf PhoneNumberVN_Execute)
      Else
        aa = aa(0)
r:
        AddArguments = PhoneVNConvert(Numbers:=aa, _
                    Delimiter:=.Delimiter, _
                    includeInvalid:=.includeInvalid, _
                    Expand:=.Expand, _
                    ZeroFrontNumber:=.ZeroFrontNumber, _
                    Header:=.Header, _
                    ReturnOrder:=.ReturnOrder, _
                    ReturnNewNumber:=.NewPhoneNumber, _
                    ReturnOldNumber:=.OldPhoneNumber, _
                    ReturnStandardsE164:=.ReturnStandardsE164, _
                    ReturnCompany:=.ReturnCompany, _
                    ReturnInvalid:=.ReturnInvalid)
        .Action = UDFNFinally: GoSub E
      End If
    Case CPSResultColumns
      .ReturnOrder = arguments(0)
      .NewPhoneNumber = arguments(1)
      .OldPhoneNumber = arguments(2)
      .ReturnStandardsE164 = arguments(3)
      .ReturnCompany = arguments(4)
      .ReturnInvalid = arguments(5)
    Case CPSHeader: .Header = True
    Case CPSDelimiter: .Delimiter = arguments(0)
    Case CPSincludeInvalid: .includeInvalid = True
    Case CPSExpand: .Expand = True
    Case CPSZeroFrontNumber: .ZeroFrontNumber = True
    End Select
  End With
Exit Function
E:
  Call SetTimer(Application.Hwnd, 21112, 0, AddressOf PhoneNumberVN_Execute)
Return
v:
  If k > i Then i = k
Return
End Function

Private Sub PhoneNumberVN_Execute(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal nIDEvent As LongPtr, ByVal dwTimer As LongPtr)
  On Error Resume Next
  Call KillTimer(Hwnd, nIDEvent)
  Select Case nIDEvent
  Case 21111: Call PhoneNumberVN_working
  Case 21112:
    Dim k%, i%, j%
    k = UBound(Works)
    For i = 1 To k
      If Works(i).Action = UDFNFinally Then j = j + 1
    Next
    If j >= k Then Erase Works
  End Select
End Sub

Private Sub PhoneNumberVN_working()
  On Error Resume Next
  Debug.Print "PhoneNumberVN_working"
  'If ThisWorkbook.BookJustSaved Then Erase Works: Exit Sub
  Dim ub As Integer, a As Object, b As TypeArguments, i&, cfl%, su As Boolean, ac As Boolean, ee As Boolean, rg As Range
  ub = UBound(Works)
  Dim o, sh, f$, aa, lr&, lr2&

  For i = 1 To ub
    b = Works(i)
    If b.Action <> UDFN__2 Then GoTo n
    If b.XLNew Then f = b.caller.Formula2 Else f = b.caller.formula
    If f <> b.fx Then GoTo n
    If a Is Nothing Then
      Set a = Application
      su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
      ee = a.EnableEvents: If ee Then a.EnableEvents = False
      ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
    End If
    Select Case b.Direction
    Case CPSMainFX
      Set rg = b.Target
      lr = rg(rg.Rows.Count + 2, 1).End(3).Row - rg.Row + 1
      If lr > 0 Then
        With b
          aa = PhoneVNConvert(Numbers:=rg.Resize(lr), _
                      Delimiter:=.Delimiter, _
                      includeInvalid:=.includeInvalid, _
                      Expand:=.Expand, _
                      ZeroFrontNumber:=.ZeroFrontNumber, _
                      Header:=.Header, _
                      ReturnOrder:=.ReturnOrder, _
                      ReturnNewNumber:=.NewPhoneNumber, _
                      ReturnOldNumber:=.OldPhoneNumber, _
                      ReturnStandardsE164:=.ReturnStandardsE164, _
                      ReturnCompany:=.ReturnCompany, _
                      ReturnInvalid:=.ReturnInvalid)
        End With
        lr2 = UBound(aa)
        If lr2 > 0 Then
          Works(i).resultArray = aa(1, 1)
          b.caller.Resize(lr2, UBound(aa, 2)).Value = aa
          If b.XLNew Then
            b.caller.Formula2 = b.fx
          Else
            b.caller.formula = b.fx
          End If
          Works(i).Action = UDFN__3
        Else
          Works(i).Action = UDFNFinally
        End If
      End If
      If lr2 = 0 Then lr2 = 1
      Call AreaClearContents(b.caller(lr2 + 1, 1), 0, 0, 0, CLng(b.columns))
    End Select
n:
  Next
E:
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
    If ac And xlCalculationAutomatic <> a.Calculation Then a.Calculation = ac
    Set a = Nothing
  End If
End Sub

' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\

Private Sub PhoneVNConvert_test()
  Call PhoneVNConvert("01681234567016812345670168123456701681234567", , , , , 1, 1, 2, 3, 4, 5, 6)
End Sub
Function PhoneVNConvert(ByVal Numbers, _
        Optional ByVal Delimiter As String = ",", _
        Optional ByVal includeInvalid As Boolean, _
        Optional ByVal Expand As Boolean, _
        Optional ByVal ZeroFrontNumber As Boolean, _
        Optional ByVal Header As Boolean, _
        Optional ByVal ReturnOrder As Integer, _
        Optional ByVal ReturnNewNumber As Integer, _
        Optional ByVal ReturnOldNumber As Integer, _
        Optional ByVal ReturnStandardsE164 As Integer, _
        Optional ByVal ReturnCompany As Integer, _
        Optional ByVal ReturnInvalid As Integer) As Variant
  Dim nbs, P$, NB$, P1$, P2$, P3$, P4$, P5$, s, T, S0$, S1$, S2$, S3$, S4$, S5$, y%, m%
  Dim i As Byte, k&, kk&, c&, L&, f&, Z&, r&, n$, j$, total$(), a(6), ms, m1, m2, D
  Static RE As Object
  nbs = Numbers: If Not IsArray(nbs) Then nbs = Array(nbs)
  m = -Header
  j = IIf(ZeroFrontNumber, "'", n)
  a(1) = ReturnOrder
  a(2) = ReturnNewNumber
  a(3) = ReturnOldNumber
  a(4) = ReturnStandardsE164
  a(5) = ReturnCompany
  a(6) = ReturnInvalid
  If a(1) > y Then y = a(1)
  If a(2) > y Then y = a(2)
  If a(3) > y Then y = a(3)
  If a(4) > y Then y = a(4)
  If a(5) > y Then y = a(5)
  If a(6) > y Then y = a(6)
  If RE Is Nothing Then
    Set RE = VBA.CreateObject("VBScript.RegExp")
    With RE
      .IgnoreCase = 1: .Global = 1
      .Pattern = "\(?(0|84|\+84|084|0084)?\)? ?(" & _
        "((?:3[2-9])|(?:86)|(?:9[6-8])" & "|(?:16[2-9]))" & _
        "|((?:7[06-9])|(?:9[03])|(?:89)" & "|(?:12[01268]))" & _
        "|((?:8[1-58])|(?:9[14])" & "|(?:12[34579]))" & _
        "|((?:5[68])|(?:92)" & "|(?:18[68]))" & _
        "|((?:59)|(?:99)" & "|(?:199))" & ")[ -]?" & _
                 "(\d[ -]?\d[ -]?\d)[ -]?(\d[ -]?\d)[ -]?(\d{2})([1-9]*)"
    End With
  End If
  If y And Header Then
    k = 1
    ReDim Preserve total(1 To y, 1 To 1):
    If ReturnOrder Then total(ReturnOrder, 1) = "#"
    P1 = "S" & ChrW(7889) & " m" & ChrW(7899) & "i"
    P2 = "S" & ChrW(7889) & " c" & ChrW(361)
    P3 = ChrW(272) & ChrW(7883) & "nh d" & ChrW(7841) & "ng ti" & ChrW(234) & "u chu" & ChrW(7849) & "n"
    P4 = "Nh" & ChrW(224) & " m" & ChrW(7841) & "ng"
    P5 = "Kh" & ChrW(244) & "ng h" & ChrW(7907) & "p l" & ChrW(7879)
    GoSub r
  End If
  For Each s In nbs: GoSub v: Next
  If y Then PhoneVNConvert = Application.Transpose(total) Else PhoneVNConvert = P
  Set RE = Nothing
Exit Function
v:
  P = s
  Set D = CreateObject("Scripting.Dictionary"): D.CompareMode = 1
  With RE
    If y And Not Expand Then GoSub a
    If .Test(s) Then
      P = n: Set ms = .Execute(s)
      For r = 1 To ms.Count
        Set m1 = ms(r - 1): Set m2 = m1.SubMatches
        c = m2.Count
        S0 = m2(0): S1 = m2(1): S2 = m2(c - 4): S3 = m2(c - 3): S4 = m2(c - 2): S5 = m2(c - 1)
        T = Right(S1, 1)
        If y And Expand Then
          f = m1.FirstIndex: Z = m1.Length
          If includeInvalid And (f > L + 2) Then
            GoSub a
            If ReturnInvalid Then total(ReturnInvalid, k) = Mid(s, L + 1, f - L)
          End If
          L = f + Z: GoSub a
        End If

        If ReturnCompany Then
          For i = 2 To 6
            If m2(i) <> n Then
              Select Case i
              Case 2: P = "Viettel"
              Case 3: P = "MobileFone"
              Case 4: P = "VinaPhone"
              Case 5: P = "Vietnamobile"
              Case 6: P = "Beeline/Gmobile"
              Case Else: P = n
              End Select
              Exit For
            End If
          Next
        End If
        Select Case True
        Case S1 Like "16[2-9]": S1 = "3" & T
        Case S1 = "120": S1 = "70"
        Case S1 = "121": S1 = "79"
        Case S1 = "122": S1 = "77"
        Case S1 Like "12[68]": S1 = "7" & T
        Case S1 Like "12[345]": S1 = "8" & T
        Case S1 = "127": S1 = "81"
        Case S1 = "129": S1 = "82"
        Case S1 Like "18[68]": S1 = "5" & T
        Case S1 = "199": S1 = "59"
        End Select
        NB = "0" & S1 & S2 & S3 & S4
        If Not D.exists(NB) Then
          D.Add NB, NB
          P1 = P1 & IIf(P1 <> n, Delimiter, j) & "0" & S1 & S2 & S3 & S4
          P2 = P2 & IIf(P2 <> n, Delimiter, j) & IIf(S1 <> CStr(m2(1)), S0 & m2(1) & S2 & S3 & S4, n)
          P3 = P3 & IIf(P3 <> n, Delimiter, n) & "(84)" & S1 & " " & S2 & "-" & S3 & S4
          P4 = P4 & IIf(P4 <> n, Delimiter, n) & P
          P5 = P5 & IIf(P5 <> n, Delimiter, j) & IIf(m2(10) <> vbNullString, S5, n)
          P = P1
          If y And Expand Then GoSub r
        End If
      Next
      If y And Not Expand Then GoSub r
    Else
 
    End If
  End With
Return
a:
  kk = kk + 1: k = kk + m
  ReDim Preserve total(1 To y, 1 To k)
  If ReturnOrder Then total(ReturnOrder, k) = kk
Return
r:
  If ReturnNewNumber Then total(ReturnNewNumber, k) = P1
  If ReturnOldNumber Then total(ReturnOldNumber, k) = P2
  If ReturnStandardsE164 Then total(ReturnStandardsE164, k) = P3
  If ReturnCompany Then total(ReturnCompany, k) = P4
  If ReturnInvalid Then total(ReturnInvalid, k) = P5
  P1 = n: P2 = n: P3 = n: P4 = n: P5 = n
Return
End Function

Sub AreaClearContents(ByVal vRange As Object, Optional ByVal OffsetRow&, Optional ByVal OffsetColumn&, Optional LimitRow&, Optional LimitColumn&)
  Dim r As Object
  Set r = AreaFromTarget(vRange, OffsetRow&, OffsetColumn&, LimitRow, LimitColumn)
  If Not r Is Nothing Then
    r.ClearContents
    Set r = Nothing
  End If
End Sub

Public Function AreaFromTarget(ByVal vRange As Object, _
                    Optional ByVal OffsetRow&, _
                    Optional ByVal OffsetColumn&, _
                    Optional LimitRow&, _
                    Optional LimitColumn&) As Object
  Dim r As Range, T As Range, r1&, C1&, R2&, C2&
  r1 = OffsetRow
  C1 = OffsetColumn
  Set r = vRange(1, 1)
  Set T = r.CurrentRegion
  If T.Cells.Count > 1 Then
    R2 = T.Row + T.Rows.Count - r.Row - r1 + 1
    C2 = T.Column + T.columns.Count - r.Column - C1 + 1
    If LimitRow > 0 Then
      R2 = IIf(LimitRow < R2, LimitRow, R2)
    End If
    If LimitColumn > 0 Then
      C2 = IIf(LimitColumn < C2, LimitColumn, C2)
    End If
    If R2 > 1 And C2 > 1 Then
      Set AreaFromTarget = r(r1 + 1, C1 + 1).Resize(R2, C2)
    End If
  End If
  Set r = Nothing
  Set T = Nothing
End Function

Private Function XLAppVersion(Optional newVersion As Boolean, Optional implicitIntersectionOperator$, Optional SpillOperator$) As Long
  Static n&, v&, i1$, i2$
  If n <> 0 Then XLAppVersion = v: newVersion = n = 1: implicitIntersectionOperator = i1: SpillOperator = i2: Exit Function
  Dim registryObject As Object
  Dim rootDirectory$
  Dim keyPath$
  Dim arrEntryNames As Variant
  Dim arrValueTypes As Variant
  Dim x&
  Select Case Val(Application.Version)
  Case Is = 16
    'Check for existence of Licensing key
    i1 = "@"
    keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
    rootDirectory = "."
    Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
    registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
    On Error GoTo ErrorExit
    For x = 0 To UBound(arrEntryNames)
      If InStr(arrEntryNames(x), "365") > 0 Then n = 1: v = 365: Exit For
      If InStr(arrEntryNames(x), "2019") > 0 Then
        If Application.Build >= 14332 Then
          'ProductCode: {90160000-000F-0000-1000-0000000FF1CE}
          'CalculationVersion:  191029
          n = 1: i2 = "#": v = 2021
        Else
          n = -1: v = 2019
        End If
        Exit For
      End If
      If InStr(arrEntryNames(x), "2016") > 0 Then v = 2016: n = -1: Exit For
    Next x
  Case Is = 15: n = -1: v = 2013
  Case Is = 14: n = -1: v = 2010 'ProductCode: {91140000-0011-0000-1000-0000000FF1CE} 'CalculationVersion:  145621
  Case Is = 12: n = -1: v = 2007
  Case Else: n = -1: v = 0
  End Select
  newVersion = n = 1: XLAppVersion = v: implicitIntersectionOperator = i1: SpillOperator = i2
Exit Function
ErrorExit:
  'Version 16, but no licensing key. Must be Office 2016
  v = 2016: n = -1: XLAppVersion = v: newVersion = n = 1
End Function