ValidateEmailFormat

' ValidateEmailFormat
' -----------------
' Macro Name: ValidateEmailFormat
' Description: 選択範囲のメールアドレス形式を検証する
' Parameters: なし
' Returns: なし
' Usage: メールアドレスが入力されたセル範囲を選択して実行
' -----------------

Sub ValidateEmailFormat()
    Dim cell As Range
    Dim validCount As Long
    Dim invalidCount As Long
    Dim outputRow As Long
    Dim ws As Worksheet
    Dim resultWs As Worksheet
    Dim emailPattern As String
    Dim i As Long

    On Error GoTo ErrorHandler

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択してください。", vbExclamation
        Exit Sub
    End If

    emailPattern = "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$"

    validCount = 0
    invalidCount = 0

    Set resultWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    resultWs.Name = "メール検証_" & Format(Now, "hhnnss")

    resultWs.Cells(1, 1).Value = "メール検証結果"
    resultWs.Cells(1, 1).Font.Bold = True
    resultWs.Cells(1, 1).Font.Size = 14

    resultWs.Cells(3, 1).Value = "セル"
    resultWs.Cells(3, 2).Value = "メールアドレス"
    resultWs.Cells(3, 3).Value = "結果"
    resultWs.Cells(3, 1).Font.Bold = True
    resultWs.Cells(3, 2).Font.Bold = True
    resultWs.Cells(3, 3).Font.Bold = True
    resultWs.Range(resultWs.Cells(3, 1), resultWs.Cells(3, 3)).Interior.Color = RGB(200, 200, 200)

    outputRow = 4

    For Each cell In Selection
        If cell.Value <> "" Then
            Dim emailAddr As String
            emailAddr = CStr(cell.Value)

            If IsValidEmail(emailAddr, emailPattern) Then
                resultWs.Cells(outputRow, 1).Value = cell.Address
                resultWs.Cells(outputRow, 2).Value = emailAddr
                resultWs.Cells(outputRow, 3).Value = "有効"
                resultWs.Cells(outputRow, 3).Font.Color = RGB(0, 128, 0)
                validCount = validCount + 1
            Else
                resultWs.Cells(outputRow, 1).Value = cell.Address
                resultWs.Cells(outputRow, 2).Value = emailAddr
                resultWs.Cells(outputRow, 3).Value = "無効"
                resultWs.Cells(outputRow, 3).Font.Color = RGB(255, 0, 0)
                resultWs.Cells(outputRow, 1).Interior.Color = RGB(255, 230, 230)
                resultWs.Cells(outputRow, 2).Interior.Color = RGB(255, 230, 230)
                resultWs.Cells(outputRow, 3).Interior.Color = RGB(255, 230, 230)
                invalidCount = invalidCount + 1
            End If
            outputRow = outputRow + 1
        End If
    Next cell

    resultWs.Cells(outputRow + 1, 1).Value = "合計: " & (validCount + invalidCount) & " 件"
    resultWs.Cells(outputRow + 1, 2).Value = "有効: " & validCount & " / 無効: " & invalidCount

    resultWs.Columns("A:C").AutoFit
    resultWs.Select

    MsgBox "検証完了: 有効 " & validCount & " 件、無効 " & invalidCount & " 件", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
End Sub

Private Function IsValidEmail(email As String, pattern As String) As Boolean
    Dim regEx As Object

    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = pattern
    regEx.IgnoreCase = True

    IsValidEmail = regEx.Test(email)
End Function