［Excel］：選択範囲の数字以外の文字を消したい　（解決編２）

Microsoft Office

昨日眠かったので。。。

数字と小数点を抜き出すマクロ（アドイン）を作った
エラー処理は一つもしていないので、なんとかしたい。

インプットボックスからセルの範囲を取得できるなら
そのほうがわかりやすい気がする。かも。


'__________ ■ ThisWorkbook.clsの内容 __________

Option Explicit

'***** アドインのインストール時
Private Sub Workbook_AddinInstall()

    '***** アドイン用コマンドバーを追加
    Dim Menubar As CommandBar
    Set Menubar = Application.CommandBars.Add(Name:="数値抽出アドイン")

    '***** コマンドボタンを設定
    With Menubar.Controls.Add(Type:=msoControlButton)
        .FaceId = 59
        .Style = msoButtonIconAndCaption
        .Caption = "数値抽出"
        .TooltipText = "選択範囲の数値を抽出します"
        .OnAction = "mcr_NumPickOut"
    End With

    Menubar.Visible = True

End Sub

Option Explicit


'__________ ■ もじゅーる１の内容 __________

Sub mcr_NumPickOut()

    '***** マクロ処理を画面表示しない
    Application.ScreenUpdating = False


'__________ 変数設定 __________

    '***** 現在開いているシート
    Dim wActive As Worksheet
    Set wActive = ActiveWorkbook.ActiveSheet

    '***** 選択範囲
    '***** （左）
    Dim cSelect_Left As Long
    cSelect_Left = Selection.Column
    '***** （右）
    Dim cSelect_Right As Long
    cSelect_Right = Selection.Column + Selection.Columns.Count - 1
    '***** （上）
    Dim cSelect_Top As Long
    cSelect_Top = Selection.Row
    '***** （下）
    Dim cSelect_Under As Long
    cSelect_Under = Selection.Row + Selection.Rows.Count - 1


'__________ 処理（新規シート作成） __________

    '***** 「変換後」シートを作成
    Sheets.Add.Name = "変換後"


'__________ 処理（数字抽出） __________

    '***** 処理シート
    Dim wWork As Worksheet
    Set wWork = ActiveWorkbook.Worksheets("変換後")

    '***** ループ用
    '***** （列）選択範囲の左端
    Dim i_Col As Long
    i_Col = cSelect_Left
    '***** （行）選択範囲の上端
    Dim i_Row As Long
    i_Row = cSelect_Top
    '***** （セル）文字数
    Dim i_Len As Long
    i_Len = 1

    '***** 処理セル
    '***** 参照元のセル
    Dim cActive As String
    cActive = wActive.Cells(i_Row, i_Col)
    '***** 変換後のセル
    Dim cWork As String
    cWork = wWork.Cells(i_Row, i_Col)

    '***** 列ループ
    For i_Col = cSelect_Left To cSelect_Right

        '***** 行ループ
        For i_Row = cSelect_Top To cSelect_Under

        '***** 次のセルへ移るため変数の初期化
        cActive = wActive.Cells(i_Row, i_Col)
        cWork = wWork.Cells(i_Row, i_Col)

            '***** 文字ループ
            For i_Len = 1 To Len(cActive)

                '***** 条件：0〜9の数字
                If Mid(cActive, i_Len, 1) Like "[0-9]" Then
                    '***** 一致でセルへ入力
                    cWork = cWork & Mid(cActive, i_Len, 1)
                    wWork.Cells(i_Row, i_Col) = cWork
                Else
                    '***** 条件：小数点
                    If Mid(cActive, i_Len, 1) = "." Then
                        cWork = cWork & Mid(cActive, i_Len, 1)
                    wWork.Cells(i_Row, i_Col) = cWork
                    End If
                End If

            Next i_Len

        Next i_Row

    Next i_Col


'__________ 処理（終了処理） __________

    '***** 変換後のシートを選択
    With wWork
        .Activate
        .Cells(1, 1).Select
        '***** シート名が被らないように名前変更
        .Name = "変換後_" & Second(Now)
    End With

    '***** 完了のメッセージ表示
    Call MsgBox("数値の抽出をしました", vbInformation, "処理完了")

    '***** 画面表示を戻す
    Application.ScreenUpdating = True

End Sub