使用VBA格式化表格

主要功能：

1.检查电话号码位数，判断是否合法。错误电话号码显示为背景红色，并前缀"错误"

2.检查身份证是否合法，并将身份证单元格格式设置为文本，避免显示异常。错误身份证显示为背景红色，并前缀"错误"

3.将字体设置为微软雅黑10号字，居中对齐，表格加边框

Sub 格式整理()
    Dim maxRow As Integer, maxCol As Integer
    Worksheets("Sheet1").Activate
    maxRow = ActiveSheet.UsedRange.Rows.Count
    maxCol = ActiveSheet.UsedRange.Columns.Count

    '整理时间格式
    formatDate maxRow
    '整理身份证格式
    formatIDCard maxRow
    '整理电话格式
    formatPhone maxRow
    '调整字体对齐
    formatFont

    MsgBox "整理完成", vbInformation, "提示"
End Sub

Function formatDate(ByVal maxRow As Long)
    Dim arr()
    Dim text As String
    Application.ScreenUpdating = False
    '日期列
    arr = Array(2, 8, 9, 12, 13, 14, 16, 17, 20, 21)
    With ActiveSheet
        For i = 2 To maxRow
            For Each col In arr
                text = .Cells(i, col).FormulaR1C1
                .Cells(i, col).NumberFormatLocal = "m""月""d""日"""
                .Cells(i, col).FormulaR1C1 = text
                With Cells(i, col)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                End With
            Next
        Next
    End With
    Application.ScreenUpdating = True
    Debug.Print "日期格式整理完成"
End Function

'整理身份证
Function formatIDCard(ByVal maxRow As Long)
  Application.ScreenUpdating = False
  For i = 2 To maxRow
    changeView i, 6
  Next
  Application.ScreenUpdating = True
  Debug.Print "身份证整理完成"
End Function

'整理电话格式
Function formatPhone(ByVal maxRow As Long)
  Application.ScreenUpdating = False
  For i = 2 To maxRow
    checkPhone i, 5
  Next
  Debug.Print "电话整理完成"
End Function

'调整字体边框对齐
Function formatFont()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Select
    '调整字体
    With Selection.Font
        .Name = "微软雅黑"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .TintAndShade = 0
        .Bold = False
    End With

    '加边框
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

    '调整居中
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .RowHeight = 16.5
    End With
    Application.ScreenUpdating = True
    Debug.Print "字体样式调整完成"
End Function

'正则测试函数
Function bTest(ByVal s As String, ByVal p As String) As Boolean
  Dim re
  Set re = CreateObject("VBScript.RegExp")
  re.IgnoreCase = False '设置是否匹配大小写
  re.Pattern = p
  bTest = re.Test(s)
End Function

'提取正则匹配内容
Function getNum(ByVal s As String, ByVal p As String) As String
    Dim re, mh, mhk
    Set reg = CreateObject("VBScript.RegExp")
    reg.Pattern = p
    Set mh = reg.Execute(s)
    Set mhk = mh.Item(0)
    getNum = mhk.Value
End Function

'提取身份证信息
Function getCard(ByVal s As String) As String
    Dim p As String, d As String
    p = "^(\d{18}|\d{17}\w)$"
    d = "[^\d\w]"
    s = reStr(s, d)
    If bTest(s, p) Then
        getCard = getNum(s, p)
        'Debug.Print getCard
    Else
        Debug.Print s & "不是有效身份信息"
        getCard = "错误" & s
    End If
End Function

'提取电话号码
Function getPhone(ByVal s As String) As String
    Dim p As String, d As String
    d = "[^\d]"
    p = "^1\d{10}$"
    s = reStr(s,d)
    If bTest(s, p) Then
        getPhone = getNum(s, p)
        'Debug.Print getPhone
    Else
        Debug.Print s & "不是有效电话号码"
        getPhone = "错误" & s
    End If
End Function

'更改身份证单元格格式
Function changeView(ByVal x As Integer, ByVal y As Integer)
    Dim text As String
    With ActiveSheet.Cells(x, y)
        text = .FormulaR1C1
        text = getCard(text)
        .NumberFormatLocal = "@"
        .FormulaR1C1 = text
        If InStr(1, text, "错误", vbTextCompare) = 1 Then
             .Interior.Color = 255
        End If
    End With
End Function

'检查电话号码
Function checkPhone(ByVal x As Integer, ByVal y As Integer)
    Dim text As String
    With ActiveSheet.Cells(x, y)
        text = .FormulaR1C1
        text = getPhone(text)
        .NumberFormatLocal = "@"
        .FormulaR1C1 = text
        If InStr(1, text, "错误", vbTextCompare) = 1 Then
             .Interior.Color = 255
        End If
    End With
End Function

'正则删除
Function reStr(ByVal s As String, ByVal p As String) As String
    Dim re
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = p
    re.Global = True
    reStr = re.Replace(s, "")
End Function