ExtractText

' ExtractText
' -----------------
' Macro Name: ExtractText
' Description: 文字列から英字のみを抽出する
' Parameters: なし
' Returns: なし
' Usage: 英字を抽出する文字列が含まれるセル範囲を選択して実行
' -----------------

Sub ExtractText()
    Dim cell As Range
    Dim resultWs As Worksheet
    Dim outputRow As Long

    On Error GoTo ErrorHandler

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

    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 originalText As String
            Dim extractedTxt As String
            Dim i As Long

            originalText = CStr(cell.Value)
            extractedTxt = ""

            For i = 1 To Len(originalText)
                Dim ch As String
                ch = Mid(originalText, i, 1)
                If (ch >= "a" And ch <= "z") Or (ch >= "A" And ch <= "Z") Then
                    extractedTxt = extractedTxt & ch
                End If
            Next i

            resultWs.Cells(outputRow, 1).Value = cell.Address
            resultWs.Cells(outputRow, 2).Value = originalText
            resultWs.Cells(outputRow, 3).Value = extractedTxt
            outputRow = outputRow + 1
        End If
    Next cell

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

    MsgBox "英字抽出が完了しました。", vbInformation
    Exit Sub

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