ExtractNumbers

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

Sub ExtractNumbers()
    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 extractedNum As String
            Dim i As Long

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

            For i = 1 To Len(originalText)
                Dim ch As String
                ch = Mid(originalText, i, 1)
                If ch >= "0" And ch <= "9" Then
                    extractedNum = extractedNum & ch
                End If
            Next i

            resultWs.Cells(outputRow, 1).Value = cell.Address
            resultWs.Cells(outputRow, 2).Value = originalText
            resultWs.Cells(outputRow, 3).Value = extractedNum
            If extractedNum <> "" Then
                resultWs.Cells(outputRow, 3).NumberFormat = "@"
            End If
            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