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