Excelの名前定義を大掃除するVBAマクロ

下書きの肥やしになってるのが邪魔なので公開。

# 2018/05/17追記
こっちのが便利って紹介してもらったので、記事に載せておく。
https://www.microsoft.com/ja-jp/store/p/xlstylestool/9wzdncrfjptg

以降は、一応残しておきますが、上のツールのが良いかと。
（ファイル上書きされるらしいので、利用時はバックアップとってご利用下さい。）

---

#はじめに
年末に向けて大掃除をしましょう。
名前定義が何に影響するか分からない人は使わないようにお願いします。
必要に応じてテキトーにソースいじって下さい。

#使い方
1. 以下コードを保存したエクセルファイルを作りましょう。
2. そのエクセルファイルから、「名前定義削除」を呼び出しましょう。
3. 名前定義を消したいファイルを選択するダイアログが表示されます。
4. 選びます。
5. 消えます。
6. ファイルを上書き保存するか聞かれます。
7. OKなら上書きして終了/NOなら保存せずに終了します

#コード
```vbnet
Option Explicit
Public 削除カウント As Long

Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Function 名前重複ならし()
    Call IME設定

    Dim beforeReferenceStyle As Variant
    beforeReferenceStyle = Application.ReferenceStyle
 
    Dim timerID As Long
    timerID = SetTimer(0, 0, 100, AddressOf TimerProc)
 
    If beforeReferenceStyle = xlR1C1 Then
        Application.ReferenceStyle = xlA1
    Else
        Application.ReferenceStyle = xlR1C1
    End If
 
    Application.ReferenceStyle = beforeReferenceStyle
 
    KillTimer 0, timerID
 
End Function
Function TimerProc()
 
    Dim hwnd As Long
    hwnd = FindWindow("bosa_sdm_XL9", "名前の重複")
 
    If hwnd > 0 Then
        SendKeys getRandomString(3, 20), 10
        SendKeys "{ENTER}"
    End If
 
End Function
Function getRandomString(min As Long, max As Long) As String
 
    Dim s As String
    Dim i As Long
 
    max = Int(max * Rnd)
 
    For i = 0 To min + max
        Randomize
        s = s & Chr(65 + Int(26 * Rnd))
    Next
 
    getRandomString = s
 
End Function
Function IME設定()
    '強制的に半角入力に変更
    With Sheets("Sheet1").Range("A1:A10").Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
        .IMEMode = xlIMEModeOn
        .IMEMode = xlIMEModeOff
    End With
End Function
Function 名前削除処理()
  Dim objName As Name

  For Each objName In ActiveWorkbook.Names
    
    '多少の失敗は気にせず次に行く
    On Error GoTo ERR_01
    
    'もし削除したくないタイプの名前定義あれば、ここを弄くれば良いデスよ
    If (objName.Value Like "*[#]REF*") Then
        '参照エラーの削除
        objName.Delete
        削除カウント = 削除カウント + 1
    ElseIf (objName.Value Like "*Print_Area*") Or (objName.Value Like "*Print_Titles*") Then
        '印刷範囲指定系の名前定義を削除
        objName.Delete
        削除カウント = 削除カウント + 1
    Else
        'それ以外を削除
        objName.Delete
        削除カウント = 削除カウント + 1
    End If
    
    Application.StatusBar = "処理中....削除件数：" & 削除カウント
    
ERR_01:
  Next objName

End Function
Function 指定フォルダ取得() As String
    指定フォルダ取得 = ""
    Dim f As Object
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Excel2003", "*.xls"
        .Filters.Add "Excelファイル", "*.xlsx"
        .Filters.Add "Excelマクロ有効", "*.xlsm"
        .AllowMultiSelect = False
        .Title = "名前定義を削除するファイルを選択してください"
        If .Show = True Then
            指定フォルダ取得 = .SelectedItems(1)
        End If
    End With
End Function
Public Sub 名前定義削除()
    Dim ファイルパス
    Dim targetbook As Workbook
    ファイルパス = 指定フォルダ取得
    Workbooks.Open Filename:=ファイルパス
    If Err.Number > 0 Then
        MsgBox "ファイルを開けませんでしたので、終了します。"
    Else
        Set targetbook = Workbooks(ActiveWorkbook.Name)
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.StatusBar = "処理中...."
        
        On Error Resume Next
        削除カウント = 0
        
        '重複している名前をそれぞれ別の名前にする（ランダムに変換するので元に戻せません）
        Call 名前重複ならし
        
        '削除処理はこちら
        Call 名前削除処理
        
        '最終確認
        Dim rc As Integer
        rc = MsgBox("保存しますか？" & "(" & 削除カウント & "件削除)" & vbCrLf & "　YES：保存して終了（戻せません）" & vbCrLf & "　NO：保存せずに終了（処理前と変わりません））", vbYesNo + vbExclamation, "最終確認")
        
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Application.StatusBar = False
        
        If rc = vbYes Then
            targetbook.Close SaveChanges:=True
            MsgBox "保存して終了しました"
        Else
            targetbook.Close SaveChanges:=False
            MsgBox "キャンセルしました（保存せずに終了しました）"
        End If
    End If
End Sub
```