VBA 範囲"シート"で重複している名前の削除、範囲"ブック"から"シート"への変更

前提

Windows10, Microsoft Office Professional Plus 2016

別ブックからのシートコピー時に持ち込んでしまったことで
重複していたり、参照できない状態になっている不要な名前定義が多いため
VBAで名前の管理の整理を行おうとしています。

下記の "NamesDelREF()"実行時に
参照範囲が"=#REF!#REF!"の名前の削除の際に範囲"ブック"の名前ではなく、同名の範囲がシートの名前定義を削除してしまう。

実現したいこと

-[1] 範囲"ブック"の名前をすべて範囲"シート"に変更
-[2] [1]の際重複するとエラーになるため、参照範囲がエラーになっている方の名前を削除し、なっていない名前を範囲"シート"で保持したい

-[3] 同名で範囲が"シート"のエラーになっている名前の削除

発生している問題・エラーメッセージ

名前の削除時に範囲が"ブック"のものが選択されて範囲が"シート"の名前が削除できない

実行前の形
名前 値 参照範囲 範囲 コメント
tmpNM1 =#REF!#REF! ブック
tmpNM1 あ1 =Sheet1!A1 Sheet1
tmpNM2 あ2 =Sheet1!A2 ブック
tmpNM2 =#REF!#REF! Sheet1

実行後の形
名前 値 参照範囲 範囲 コメント
tmpNM2 あ2 =Sheet1!A2 Sheet1

求めている形
名前 値 参照範囲 範囲 コメント
tmpNM1 あ1 =Sheet1!A1 Sheet1

tmpNM2 あ2 =Sheet1!A2 Sheet1

該当のソースコード

EXCEL

sub CommandButton1_Click() NamesDelREF() NamesWBtoWS() end sub 'シートとブックの範囲でブックがREFの際にシート範囲も削除する問題あり Sub NamesDelREF() Dim nm As Integer For nm = ActiveWorkbook.Names.Count To 1 Step -1 'Debug.Print nm & vbTab & ActiveWorkbook.Names.Item(nm).RefersTo & ActiveWorkbook.Names.Item(nm).Name If (ActiveWorkbook.Names.Item(nm).RefersTo Like "*[#]REF!*") Then Debug.Print "DEL " & ActiveWorkbook.Names.Item(nm).Name ActiveWorkbook.Names.Item(nm).Delete End If Next End Sub Sub NamesWBtoWS() Dim wb As Workbook Dim ws As Worksheet Dim nm As Name Dim a, b, c, d For Each wb In Workbooks 'Debug.Print wb.Name For Each nm In wb.Names If Not (nm.RefersTo Like "*[#]REF!*") Then For Each ws In Worksheets a = Split(nm.RefersTo, "!") '=init!A1 b = Split(nm.Name, "!") 'ABC or init!ABC If UBound(b) = 0 And UBound(a) = 1 And a(0) = "=" & ws.Name Then c = nm.Name d = nm.RefersTo nm.Delete ws.Names.Add c, d Exit For End If Next a = Empty b = Empty End If Next Next End Sub