Lọc số điện thoại trong Excel với VBA
Nhiều người làm văn phòng, giáo viên… khi nghe đến VBA có một cái gì đó hơi ngán ngẫm, tuy nhiên có những hàm VBA đã được viết sẵn và bạn chỉ cần tận dụng nó một cách cho tốt là được việc rất nhiều.
Nhân tiện khách của mình copy dữ liệu khách hàng trong website woocomerce ra và có nhu cầu lọc ra các số điện thoại để sử dụng vào việc gửi sms marketing qua zalo nên trong bài viết này mình xin giới thiệu một hàm giúp bạn lọc số điện thoại trong Excel với VBA một cách cực kỳ nhanh chóng và hiệu quả
Cách bước thực hiện
Bước 1. Mở excel lên và nhấn tổ hợp phím Alt + F11, tổ hợp phím này sẽ kích hoạt cửa sổ VBA
Bước 2. Nhấn vào menu Insert – Module để tạo một module mới như hình dưới ( mình đặt tên là tachsodienthoai )
Bước 3. Bạn copy đoạn code sau và dán vào phần chứa nội dung Module
' __ _____ _ ®
' \ \ / / _ | / \
' \ \ /| _ \/ / \
' \_/ |___/_/ \_\
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
Bước 4. Quay lại Excel và dùng hàm PhoneVN như các hàm khác của Excel
Sau khi bạn dán code vào Module thì thằng Excel nó sẽ nhận thêm hàm TachSoDienThoai vào Excel, bây giờ bạn dùng hàm này một cách bình thường như các hàm khác. Chỉ khác là các hàm khác như SUM, MIN, MAX …. là của Excel định nghĩa, còn hàm PhoneVN là do đoạn code trên tự định nghĩa ra.
Cách 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 |
Nguồn bài viết : Tách số điện thoại và chuyển đổi đầu số với EXCEL | Giải Pháp Excel (giaiphapexcel.com)
