使用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