Excelの名前定義をVBAで一括解除する【実務で活用できる】

Option Explicit
Private Declare Function GetInputState Lib "USER32" () As Long 'DoEventsの代わり
Public DelCount As Long '削除数カウント用
Public NameCount As Long '名前定義数保存用
'名前定義の削除処理開始
Sub StartDelNamesDef()
    Dim selectFileName As Variant
    
    'ファイル選択ダイアログを表示
    selectFileName = _
        Application.GetOpenFilename( _
            FileFilter:="Microsoft Excel ブック,*.xls?", _
            Title:="ファイルを選択してください（複数可）", _
            MultiSelect:=True)
    If IsArray(selectFileName) = False Then _
                MsgBox ("未選択のため処理を中止します！"): Exit Sub
    'チラつきをなくすためExcelインスタンスで対応
    Dim f As Variant    'ファイル用
    Dim tgwb As Object
    Dim owb As Excel.Workbooks
    Dim oxl As Excel.Application
    Dim rc As Long
        
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "処理中...."
    Set oxl = CreateObject("Excel.Application") 'インスタンス
    Set owb = oxl.Application.Workbooks 'WBオブジェクト
    '選択されたファイルに対する処理
    On Error Resume Next
    For Each f In selectFileName
        If GetInputState() Then DoEvents    '重いファイル用対策
        'ブックを開く
        Set tgwb = owb.Open(Filename:=f, UpdateLinks:=0)
        'ここから開いたブックに対する処理
        Application.StatusBar = tgwb.name & " の処理中...."
        With tgwb
           DelCount = 0    'カウンター初期化
            '非表示になっている名前定義を表示させる
            Call VisibleNames
            '削除処理はこちら
            Call DeleteNamesDefinition
            '最終確認
            rc = MsgBox(.name & "を保存しますか？" & vbCrLf _
                    & "【削除件数は " & DelCount & "件でした】" & vbCrLf _
                    & "　はい（Y）：保存して終了（元には戻せません）" & vbCrLf _
                    & " いいえ（N）：保存せずに終了（削除前のまま）", _
                    vbYesNo + vbExclamation, "保存前の確認！")
            If rc = vbYes Then
                .Close Savechanges:=True
            Else
                .Close Savechanges:=False
            End If
        End With
        Set tgwb = Nothing
    Next
    Set owb = Nothing
    Set oxl = Nothing
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
End Sub

'名前定義を削除する処理
Sub DeleteNamesDefinition()
    Dim objName As name 'Nameオブジェクト
    Dim sh As Worksheet
    Dim rn As Range '対象外設定範囲
    Dim saveName() As String '対象外設定保存用
    Dim i As Long   '対象外の設定数
    Dim n As Long   '対象外読み込み用カウンター
    Dim r As Range  '対象外設定用フラグ
      
    Set sh = ThisWorkbook.Sheets("名前定義削除")
    With sh
        Set rn = .Range("J4", .Cells(Rows.Count, 10).End(xlUp))
        i = Application.CountIf(rn, 1) '「1」をカウント
        ReDim saveName(i - 1)   '配列数を設定
        n = 0
        For Each r In rn
            If r.Value = 1 Then
                saveName(n) = .Cells(r.Row, 11).Value
                n = n + 1
            End If
        Next
    End With
    NameCount = ActiveWorkbook.Names.Count '開いたブックの名前定義数
    'Nameコレクション内のNameオブジェクト分をループ処理
    For Each objName In ActiveWorkbook.Names
        'エラーが発生時は次のオブジェクトに飛すため
        On Error GoTo ERR_Resume
        '削除したくない名前定義を飛ばす
        If (objName.Value Like "*[#]REF*") Then '参照エラーは全て削除
            objName.Delete
            DelCount = DelCount + 1 'カウントアップ
        Else
            For i = 0 To n
                If (objName.name Like saveName(i)) Then 'これは削除しない
                Else '対処外設定以外は削除
                    objName.Delete
                    DelCount = DelCount + 1 'カウントアップ
                End If
            Next i
        End If
        Application.StatusBar = "処理中....削除件数：" & DelCount & "／" & NameCount
ERR_Resume:
    '何もせず次へ
    Next objName
End Sub

'非表示になっている名前定義を表示させる
Sub VisibleNames()
    Dim name As Object
    'Namesコレクション内のNameオブジェクト分をループ処理
    For Each name In Names
        If name.Visible = False Then
            name.Visible = True
        End If
    Next
End Sub