DeleteNameCellSelectCell

'DeleteNameCellSelectCell・・・元場所：IkiAddin.ModRibbonGeneral
'GetSelectionCell        ・・・元場所：IkiAddin.ModCell
'ClipText                ・・・元場所：IkiAddin.ModClipboard



Public Sub DeleteNameCellSelectCell()
' 20230405
' 選択範囲内のセルの名前定義を削除し、削除した名前定義の一覧をメッセージで表示する

'20240918 抜本的に処理を修正
'20251020 ActiveSheet限定の処理に変更

    Dim SelectedRange As Range
    Dim Cell          As Range
    Dim NM            As Name
    
    ' 選択範囲を取得
    Set SelectedRange = GetSelectionCell
    If SelectedRange Is Nothing Then Exit Sub

    ' 名前定義のコレクションをループして、一致する名前定義があるか確認
    Dim List_消去対象 As Variant: ReDim List_消去対象(1 To 1)
    Dim Judge         As Boolean: Judge = False
    Dim Str_定義名    As String
    Dim Sheet         As Worksheet: Set Sheet = ActiveSheet
    For Each NM In Sheet.Names
        On Error Resume Next
        If NM.Value <> "=#NAME?" And InStr(NM.Value, "#REF!") = 0 Then
            If NM.RefersToRange.Address = SelectedRange.Address Then '同じアドレス
                Str_定義名 = NM.Name
                NM.Delete
                Judge = True
                Exit For
            End If
        End If
        On Error GoTo -1
    Next NM

    '結果表示
    If Judge = True Then
        MsgBox "「" & Str_定義名 & "」を消去しました", vbInformation
        
        '消去した名前をクリップボードに格納→定義しなおすために
        If InStr(Str_定義名, "!") > 0 Then
            Str_定義名 = Split(Str_定義名, "!")(1)
        End If
        Call ClipText(Str_定義名)
    Else
        MsgBox "選択セルは名前定義が有りません", vbExclamation
    End If
    
End Sub

Private Function GetSelectionCell() As Range
'選択中のセルを取得する
'セル以外を選択している場合はNothingを返す
'20220312
'https://www.softex-celware.com/post/getselectioncell
    
    '処理
    Dim Dummy  As Object: Set Dummy = Selection
    Dim Output As Range: Set Output = Nothing
    If TypeName(Dummy) = "Range" Then
        Set Output = Dummy
    End If
    
    '出力
    Set GetSelectionCell = Output
End Function

Private Sub ClipText(ByVal Text As String)
'文字列(Text)をクリップボードに格納
'https://www.softex-celware.com/post/cliptext
'20251007 テキストのみの処理に変更

'引数
'Text・・・クリップボードに格納するテキスト
    
    'クリップボードに格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Text
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
    
End Sub