Vba 设置电话号码的格式，只保留字母数字字符，然后按照格式进行设置

这是我第一次在这里发帖。我目前正在探索VBA，我想制作一个宏来格式化电话号码并将其转换为标准格式。除数字和字母以外的所有特殊字符都应删除。我很抱歉我的英语不是很好。这里有一个例子

场景必须是这样的，我选择一个范围

8009228080

(900) (CAT) BABA

(+1) (900) (289) (9000)

900.900.9000

然后我单击宏被分配的按钮，然后它是这样的

800-922-8080

900-228-2222

900-289-9000

900-900-9000

输出必须仅为####-#-#-#-#-#-#-#（3个数字-‘3个数字-’4个数字） 这封信必须翻译成以下文字 ABC=2，DEF=3，GHI=4，JKL=5，MNO=6，PQRS=7，TUV=8，WXYZ=9 我试着查找它，下面是我的尝试：

    Sub PhoneFormat()

    Dim StSel As Range
    Dim EndSel As Range
    On Error Resume Next
    xTitleId = "Format Phone Numbers"
    Set EndSel = Application.Selection
    Set EndSel = Application.InputBox("Range", xTitleId, EndSel.Address, Type:=8)

我想更改此部分，因为我想先选择范围，然后单击按钮，然后应用宏

---

我认为这可以优化成更简单的代码，但我做不到。此代码也不能将字母替换为数字。提前感谢，我希望任何人都能回答这个问题。

下面是一个使用正则表达式的示例：

Option Explicit

Public Sub test()
    Debug.Print FormatWithRegEx("(900) (CAT) BABA")
    Debug.Print FormatWithRegEx("(+1) (900) (289) (9000)")
    Debug.Print FormatWithRegEx("900.900.9000")

    Debug.Print ReplaceCharactersWithRegEx(FormatWithRegEx("(900) (CAT) BABA")) 
    'or dircetly implement ReplaceCharactersWithRegEx in FormatWithRegEx
End Sub

Public Function FormatWithRegEx(InputString As String) As String
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")

    Dim arrPatterns() As Variant
    arrPatterns = Array( _
        "([A-Z0-9]{10})", _
        "\(?([A-Z0-9]{3})\)? \(?([A-Z0-9]{3})\)? \(?([A-Z0-9]{4})\)?", _
        "([A-Z0-9]{3})\.([A-Z0-9]{3})\.([A-Z0-9]{4})" _
    )

    Dim Pattern As Variant
    For Each Pattern In arrPatterns
        With objRegEx
            .Global = True
            .IgnoreCase = True
            .MultiLine = False
            .Pattern = Pattern

            Dim objMatches As Object
            Set objMatches = .Execute(InputString)
        End With

        If objMatches.Count = 1 Then
            With objMatches(0)
                If .SubMatches.Count = 3 Then
                    FormatWithRegEx= .SubMatches(0) & "-" & .SubMatches(1) & "-" & .SubMatches(2)
                End If
            End With
        End If
        If FormatWithRegEx <> vbNullString Then Exit For
    Next Pattern
    'to implement ReplaceCharactersWithRegEx uncomment …
    'FormatWithRegEx = ReplaceCharactersWithRegEx(FormatWithRegEx)
End Function

//编辑
使用

使其不区分大小写。IgnoreCase=True

//编辑2
选择循环示例

Dim cl As Range
For Each cl In Selection 'instead of Selection you can also use a defined Range("A1:A50")
    Dim FormattedValue As String
    FormattedValue = FormatWithRegEx(cl.value)
    If FormattedValue <> vbNullString Then 'don't delete if formatting wasn't successful
        cl.value = FormatWithRegEx(cl.value)
    End If
Next cl

Dim cl As范围
对于“选择”中的每个cl，您也可以使用定义的范围（“A1:A50”）代替“选择”
将FormattedValue设置为字符串
FormattedValue=FormatWithRegEx（cl.value）
如果FormattedValue vbNullString，则“如果格式化不成功，则不删除”
cl.value=FormatWithRegEx（cl.value）
如果结束
下一个cl

获取PEH的答案并添加字母到数字的转换：

Option Explicit

Public Sub test()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim rng As Range
Dim cell As Range
Set rng = Selection
For Each cell In rng
    cell.Value = ConvertLetters(FormatWithRegEx(cell.Value))
Next
End Sub

Public Function ConvertLetters(FormattedString As String) As String
    Dim J As Long, Digit As Variant
    For J = 1 To Len(FormattedString)
        Digit = UCase(Mid(FormattedString, J, 1))
        Select Case Digit
            Case "A" To "P"
                Digit = Chr((Asc(Digit) + 1) \ 3 + 28)
            Case "Q"
                Digit = "7"
            Case "R" To "Y"
                Digit = Chr(Asc(Digit) \ 3 + 28)
            Case "Z"
                Digit = "9"
        End Select
        Mid(FormattedString, J, 1) = Digit
    Next J
ConvertLetters = FormattedString
End Function


Public Function FormatWithRegEx(InputString As String) As String
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")

    Dim arrPatterns() As Variant
    arrPatterns = Array( _
        "\(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{3})\) ([a-zA-Z0-9]{4})", _
        "\(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{3})\) \(([a-zA-Z0-9]{4})\)", _
        "([a-zA-Z0-9]{3})\.([a-zA-Z0-9]{3})\.([a-zA-Z0-9]{4})" _
    )

    Dim Pattern As Variant
    For Each Pattern In arrPatterns
        With objRegEx
            .Global = True
            .IgnoreCase = True
            .MultiLine = False
            .Pattern = Pattern

            Dim objMatches As Object
            Set objMatches = .Execute(InputString)
        End With

        If objMatches.Count = 1 Then
            With objMatches(0)
                If .SubMatches.Count = 3 Then
                    FormatWithRegEx = .SubMatches(0) & "-" & .SubMatches(1) & "-" & .SubMatches(2)
                End If
            End With
        End If
        If FormatWithRegEx <> vbNullString Then Exit For
    Next Pattern

End Function

---

我现在已经修改了脚本以使用选定的范围，它还将转换所有给定的示例

这是很容易阅读和修改的其他目的，可能有用的人，这就是为什么我张贴它

脚本使用Case-Else删除未定义的字符，并转换所需的字符

Sub PhoneFormatRange()

        Dim myLen As Long
        Dim i As Long

        Dim myNum As String
        Dim newNum As String

        Dim selectedRng As Range
        Dim celRng As Range

        Dim strLeft As String
        Dim strMid As String
        Dim strRight As String


    ' Find the Selected Range and for each cell in the selected range run the cade and repeat.
    Set selectedRng = Application.Selection
    For Each celRng In selectedRng.Cells


    ' Convert Cell value to an array
    myLen = Len(celRng.Value)

    ReDim Carray(Len(celRng.Value))

    For i = 0 To myLen
        Carray(i) = Mid(celRng.Value, i + 1, 1)
    Next

    '   Loop through array, converting values
        If myLen > 0 Then
            For i = 0 To myLen
                Select Case Carray(i)
                     Case "0"
                        myNum = "0"
                    Case "1"
                        myNum = "1"
                    Case "2"
                        myNum = "2"
                    Case "3"
                        myNum = "3"
                    Case "4"
                        myNum = "4"
                    Case "5"
                        myNum = "5"
                    Case "6"
                        myNum = "6"
                    Case "7"
                        myNum = "7"
                    Case "8"
                        myNum = "8"
                    Case "9"
                        myNum = "9"

                    Case "A", "B", "C", "a", "b", "c"
                        myNum = "2"
                    Case "D", "E", "F", "d", "e", "f"
                        myNum = "3"
                    Case "G", "H", "I", "g", "h", "i"
                        myNum = "4"
                    Case "J", "K", "L", "j", "k", "l"
                        myNum = "5"
                    Case "M", "N", "O", "m", "n", "o"
                        myNum = "6"
                    Case "P", "Q", "R", "S", "p", "q", "r", "s"
                        myNum = "7"
                    Case "T", "U", "V", "t", "u", "v"
                        myNum = "8"
                    Case "W", "X", "Y", "Z", "w", "x", "y", "z"
                        myNum = "9"

                    Case " ", "-", "."
                        myNum = "-"

                    Case Else
                        myNum = ""

                End Select

                newNum = newNum & myNum
            Next i
        End If


    ' Check the length of the string and if it requals 10 then add the hypens
    If Len(newNum) = 10 Then

        strLeft = Left(newNum, 3)
        strMid = Mid(newNum, 4, 3)
        strRight = Right(newNum, 4)

        newNum = strLeft & "-" & strMid & "-" & strRight

    End If

    ' Set the cell value within the range to 12 right most characters of the string
    celRng.Value = Right(newNum, 12)


    ' Clear newNum before repeating
    newNum = ""

    ' Go back to celRng and repeat until all the cells within the selection is complete
    Next celRng

End Sub

---

我也像PEH一样写了一个正则表达式。但我的方法有点不同。之所以发布它，是因为编写这篇文章很有趣，而且可能会有所帮助。 我还使用了Xabiers ConvertLetters函数，因为它做得很好，代码是一种非常好的方法

我处理正则表达式的方法是在一个表达式中匹配所有标准。所以我定义的模式会找到你定义的所有可能性。这迫使我做了一些额外的替换，所以我对Xabiers代码进行了一些扩展

Sub correctNumbers()
Dim i As Long, J As Long
Dim sEXP As String
Dim rng As Range
Dim oRegEx As Object, oMatch As Object
  ' create object for regular expressions
  Set oRegEx = CreateObject("vbscript.regexp")
  ' supposed you have a sheet called "Sheet1" - change sheetname and range according to your needs
  Set rng = ThisWorkbook.Sheets("Sheet1").Range("A2:A4")

  ' run through every entry in range
  For i = 1 To rng.Rows.Count
    With oRegEx
      .Global = True
      .IgnoreCase = False
      ' define pattern as desribed by you needs
      .Pattern = "([\(]?[0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{4}[\)]?)"
      Set oMatch = .Execute(rng(i, 1).Value)
      If oMatch.Count <> 0 Then
        sEXP = oMatch(0)
        If Len(sEXP) = 10 Then
          sEXP = Left(sEXP, 3) & "-" & Right(Left(sEXP, 6), 3) & "-" & Right(sEXP, 4)
        Else
          sEXP = ConvertLetters(oMatch(0))
        End If
      Else
        sEXP = ""
      End If
    End With
    ' write result in column B
    ThisWorkbook.Sheets("Sheet1").Range("B" & i + 1).Value = sEXP
  Next i
End Sub

 Public Function ConvertLetters(FormattedString As String) As String
 Dim J As Long, Digit As Variant
 For J = 1 To Len(FormattedString)
   Digit = UCase(Mid(FormattedString, J, 1))
   Select Case Digit
     Case "A" To "P"
       Digit = Chr((Asc(Digit) + 1) \ 3 + 28)
     Case "Q"
       Digit = "7"     'May want to change
     Case "R" To "Y"
       Digit = Chr(Asc(Digit) \ 3 + 28)
     Case "Z"
       Digit = "9"     'May want to change
       ' added as my regular expression finds complete number including dots, spaces and braces
     Case ".", " "
       Digit = "-"
     End Select
     Mid(FormattedString, J, 1) = Digit
   Next J
   ' added repalce as my regular expression finds complete number including dots, spaces and braces
   ConvertLetters = Replace(Replace(FormattedString, "(", ""), ")", "")
End Function

子编号（）
我和我一样长，我和我一样长
作为字符串的Dim sEXP
变暗rng As范围
Dim oRegEx作为对象，oMatch作为对象
'为正则表达式创建对象
设置oRegEx=CreateObject（“vbscript.regexp”）
'假设您有一张名为“Sheet1”的工作表-根据需要更改工作表名称和范围
设置rng=ThisWorkbook.Sheets（“Sheet1”）.范围（“A2:A4”）
'遍历范围内的每个条目
对于i=1到rng.Rows.Count
用奥列格克斯
.Global=True
.IgnoreCase=False
'根据需要定义模式
.Pattern=“（[\（]？[0-9]{3}[\]？[\s\.]？[\（]？[A-Z0-9]{3}[\]？[\s\.]？[\（]？[A-Z0-9]{4}[\]）”
设置oMatch=.Execute（rng（i，1）.Value）
如果oMatch.Count为0，则
sEXP=oMatch（0）
如果Len（sEXP）=10，则
sEXP=Left（sEXP，3）&“-”和Right（Left（sEXP，6），3）&“-”和Right（sEXP，4）
其他的
sEXP=转换字母（oMatch（0））
如果结束
其他的
sEXP=“”
如果结束
以
'将结果写入B列
ThisWorkbook.Sheets（“Sheet1”）.范围（“B”&i+1）.值=sEXP
接下来我
端接头
公共函数将字母（FormattedString作为字符串）转换为字符串
尺寸J为长，数字为变体
对于J=1到Len（格式化字符串）
数字=UCase（Mid（格式化字符串，J，1））
选择大小写数字
案例“A”至“P”
数字=Chr（（Asc（数字）+1）\3+28）
案例“Q”
Digit=“7”可能需要更改
案例“R”至“Y”
数字=Chr（Asc（数字）\3+28）
案例“Z”
Digit=“9”可能需要更改
'添加为我的正则表达式查找完整的数字，包括点、空格和大括号
案例“，”
数字=“-”
结束选择
Mid（格式化字符串，J，1）=数字
下一个J
'添加了repalce，因为我的正则表达式可以找到完整的数字，包括点、空格和大括号
ConvertLetters=Replace（Replace（FormattedString，（“，”），“，”，”）
端函数

您想将此

（900）（CAT）BABA

格式化为什么？我会删除所有不允许的数字（这里最难删除的是我猜的国家代码），然后我会将所有字符转换为数字，因此所有条目只能是11位数字。最后我会插入破折号。或者使用正则表达式识别输入格式的所有不同可能性，然后只需将字符另外翻译成数字。@0m3r来自示例ABC=2、DEF=3、GHI=4、JKL=5、MNO=6、PQRS=7、TUV=8、WXYZ=9。谢谢@dadler我很抱歉我没有把它包括在我的post@Pᴇʜ我试图将单元格值格式化并仅更改为10个字符，这就是为什么我包括“如果（Len（StSel）>10），那么StSel=Right（StSel，10）End If”计数从右侧开始，因为国家代码/地区代码位于数字的左侧。@PEH！对不起，如果你要用勺子喂我。但是如果我要运行这个程序并使代码应用于选择（突出显示），我应该更改什么部分？如果我添加了ReplaceCharactersWithRegEx函数，会应用字母到数字的转换吗？我还编辑了我的帖子，并举了另一个例子。蒂亚@LeggoDave您需要编写自己的子函数，在选定的范围内循环，然后为每个单元格调用

FormatWithRegEx

函数。是，将应用字母到数字的转换。你需要了解所有的团队

Sub PhoneFormat()
Dim myLen As Long
Dim i As Long
Dim myNum As String
Dim newNum
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim rng As Range
Dim cell As Range
Set rng = Selection
For Each cell In rng
    '   Loop through characters, converting values
        If Len(cell.Value) > 0 Then
            For i = 1 To Len(cell.Value)
                Select Case Mid(cell.Value, i, 1)
                    Case "0"
                        myNum = "0"
                    Case "1"
                        myNum = "1"
                    Case "2"
                        myNum = "2"
                    Case "3"
                        myNum = "3"
                    Case "4"
                        myNum = "4"
                    Case "5"
                        myNum = "5"
                    Case "6"
                        myNum = "6"
                    Case "7"
                        myNum = "7"
                    Case "8"
                        myNum = "8"
                    Case "9"
                        myNum = "9"

                    Case "A", "B", "C", "a", "b", "c"
                        myNum = "2"
                    Case "D", "E", "F", "d", "e", "f"
                        myNum = "3"
                    Case "G", "H", "I", "g", "h", "i"
                        myNum = "4"
                    Case "J", "K", "L", "j", "k", "l"
                        myNum = "5"
                    Case "M", "N", "O", "m", "n", "o"
                        myNum = "6"
                    Case "P", "Q", "R", "S", "p", "q", "r", "s"
                        myNum = "7"
                    Case "T", "U", "V", "t", "u", "v"
                        myNum = "8"
                    Case "W", "X", "Y", "Z", "w", "x", "y", "z"
                        myNum = "9"

                    Case " ", "-", "."
                        myNum = "-"

                    Case Else
                        myNum = ""
                End Select
                newNum = newNum & myNum
            Next i
        End If
    cell.Value = Right(newNum, 12)
Next
End Sub

Sub PhoneFormatRange()

        Dim myLen As Long
        Dim i As Long

        Dim myNum As String
        Dim newNum As String

        Dim selectedRng As Range
        Dim celRng As Range

        Dim strLeft As String
        Dim strMid As String
        Dim strRight As String


    ' Find the Selected Range and for each cell in the selected range run the cade and repeat.
    Set selectedRng = Application.Selection
    For Each celRng In selectedRng.Cells


    ' Convert Cell value to an array
    myLen = Len(celRng.Value)

    ReDim Carray(Len(celRng.Value))

    For i = 0 To myLen
        Carray(i) = Mid(celRng.Value, i + 1, 1)
    Next

    '   Loop through array, converting values
        If myLen > 0 Then
            For i = 0 To myLen
                Select Case Carray(i)
                     Case "0"
                        myNum = "0"
                    Case "1"
                        myNum = "1"
                    Case "2"
                        myNum = "2"
                    Case "3"
                        myNum = "3"
                    Case "4"
                        myNum = "4"
                    Case "5"
                        myNum = "5"
                    Case "6"
                        myNum = "6"
                    Case "7"
                        myNum = "7"
                    Case "8"
                        myNum = "8"
                    Case "9"
                        myNum = "9"

                    Case "A", "B", "C", "a", "b", "c"
                        myNum = "2"
                    Case "D", "E", "F", "d", "e", "f"
                        myNum = "3"
                    Case "G", "H", "I", "g", "h", "i"
                        myNum = "4"
                    Case "J", "K", "L", "j", "k", "l"
                        myNum = "5"
                    Case "M", "N", "O", "m", "n", "o"
                        myNum = "6"
                    Case "P", "Q", "R", "S", "p", "q", "r", "s"
                        myNum = "7"
                    Case "T", "U", "V", "t", "u", "v"
                        myNum = "8"
                    Case "W", "X", "Y", "Z", "w", "x", "y", "z"
                        myNum = "9"

                    Case " ", "-", "."
                        myNum = "-"

                    Case Else
                        myNum = ""

                End Select

                newNum = newNum & myNum
            Next i
        End If


    ' Check the length of the string and if it requals 10 then add the hypens
    If Len(newNum) = 10 Then

        strLeft = Left(newNum, 3)
        strMid = Mid(newNum, 4, 3)
        strRight = Right(newNum, 4)

        newNum = strLeft & "-" & strMid & "-" & strRight

    End If

    ' Set the cell value within the range to 12 right most characters of the string
    celRng.Value = Right(newNum, 12)


    ' Clear newNum before repeating
    newNum = ""

    ' Go back to celRng and repeat until all the cells within the selection is complete
    Next celRng

End Sub

Sub correctNumbers()
Dim i As Long, J As Long
Dim sEXP As String
Dim rng As Range
Dim oRegEx As Object, oMatch As Object
  ' create object for regular expressions
  Set oRegEx = CreateObject("vbscript.regexp")
  ' supposed you have a sheet called "Sheet1" - change sheetname and range according to your needs
  Set rng = ThisWorkbook.Sheets("Sheet1").Range("A2:A4")

  ' run through every entry in range
  For i = 1 To rng.Rows.Count
    With oRegEx
      .Global = True
      .IgnoreCase = False
      ' define pattern as desribed by you needs
      .Pattern = "([\(]?[0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{3}[\)]?[\s\.]?[\(]?[A-Z0-9]{4}[\)]?)"
      Set oMatch = .Execute(rng(i, 1).Value)
      If oMatch.Count <> 0 Then
        sEXP = oMatch(0)
        If Len(sEXP) = 10 Then
          sEXP = Left(sEXP, 3) & "-" & Right(Left(sEXP, 6), 3) & "-" & Right(sEXP, 4)
        Else
          sEXP = ConvertLetters(oMatch(0))
        End If
      Else
        sEXP = ""
      End If
    End With
    ' write result in column B
    ThisWorkbook.Sheets("Sheet1").Range("B" & i + 1).Value = sEXP
  Next i
End Sub

 Public Function ConvertLetters(FormattedString As String) As String
 Dim J As Long, Digit As Variant
 For J = 1 To Len(FormattedString)
   Digit = UCase(Mid(FormattedString, J, 1))
   Select Case Digit
     Case "A" To "P"
       Digit = Chr((Asc(Digit) + 1) \ 3 + 28)
     Case "Q"
       Digit = "7"     'May want to change
     Case "R" To "Y"
       Digit = Chr(Asc(Digit) \ 3 + 28)
     Case "Z"
       Digit = "9"     'May want to change
       ' added as my regular expression finds complete number including dots, spaces and braces
     Case ".", " "
       Digit = "-"
     End Select
     Mid(FormattedString, J, 1) = Digit
   Next J
   ' added repalce as my regular expression finds complete number including dots, spaces and braces
   ConvertLetters = Replace(Replace(FormattedString, "(", ""), ")", "")
End Function