Excelの（名前の管理のところの）名前の範囲の編集と，名前の範囲の値から複数選択するフォームとマクロ

　Excelの「名前」って名前は何とかならないですかね．たぶんこのタイトルじゃ伝わらないですが仕方ない．

入力規則を使ってドロップダウンリストでその中のひとつを選択することはできますが，複数選択したい場合はどうするんだろうって思ったことはありませんか．標準ではできそうにないので(あるなら教えてください)作ってみました．ただ，どのイベントを使ってダイアログを出すかとか，標準ではないのでいろいろめんどうなことはありますが，今回は適当に決めてあります．

1. 名前の内容の編集
表示するリストと，追加に使用するTextの入力領域，ボタンは追加,削除,上,下とOk,Cancelがあれば何とかなるでしょう．

必要な機能は
a)名前の内容でリストの初期化
b)追加ボタンでリストに追加する
c)Textが変更されたときにリストに存在していなくて，""でなければ追加ボタンを有効にする
d)上下に移動できるときはそのボタンを有効にする
e)リストの項目が選択されている場合は削除ボタンを有効にする．

これをフォームにするとこんなかんじ

フォームを表示するためのコード

Public Sub EditStatus()
    Dim frm As ListEditForm
    Set frm = New ListEditForm
    frm.EditName ThisWorkbook.Names("status"), "statusの編集"
End Sub

フォームのコードは

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided
'that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and
'   the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
'   and the following disclaimer in the documentation and/or other materials provided with the
'   distribution.
'
'THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
'INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE
'FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
'NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
'OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
'STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
'THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

'終了したときの状態を保存します．
Public RetCode As Integer

'追加ボタンがクリックされたらリストにテキストの内容を追加する
Private Sub BAdd_Click()
    LName.AddItem Trim(TName.Text) '必要のないスペースは消しておく
    BAdd.Enabled = False
    'TODO:追加した後はテキストを削除したほうがいいのかもしれないので検討する
End Sub

'キャンセルボタンが押されたらダイアログを消す．RetCodeは初期化時に設定済み
Private Sub BCancel_Click()
    Unload Me
End Sub

'削除ボタンが押されたら，選択しているアイテムを削除する
Private Sub BDel_Click()
    For i = 0 To LName.ListCount - 1
        If LName.Selected(i) Then
            LName.RemoveItem i
            BDel.Enabled = LName.ListCount > 0
            Exit Sub
        End If
    Next
End Sub

'下にボタンが押されたときはリストの選択しているアイテムを下に動かす
Private Sub BDown_Click()
    If LName.ListIndex >= 0 Then
        Dim strWork As String
        strWork = LName.list(LName.ListIndex + 1, 0)
        LName.list(LName.ListIndex + 1, 0) = LName.list(LName.ListIndex, 0)
        LName.list(LName.ListIndex, 0) = strWork
        '選択していた位置を一つ下にする
        LName.ListIndex = LName.ListIndex + 1
    End If
End Sub

'OKボタンが押されたら，RetCodeにvbOKを代入してダイアログを消す
Private Sub BOK_Click()
    RetCode = vbOK
    Unload Me
End Sub

'上にボタンが押されたときは選択されたアイテムを上に移動する
Private Sub BUp_Click()
    If LName.ListIndex > 0 Then
        Dim strWork As String
        strWork = LName.list(LName.ListIndex - 1, 0)
        LName.list(LName.ListIndex - 1, 0) = LName.list(LName.ListIndex, 0)
        LName.list(LName.ListIndex, 0) = strWork
        'ひとつ上のアイテムを選択する
        LName.ListIndex = LName.ListIndex - 1
    End If
End Sub

'リストがクリックされたとき？（変更されたときか？）ボタンの状態を変更する
Private Sub LName_Click()
    BUp.Enabled = Not LName.Selected(0)
    BDown.Enabled = Not LName.Selected(LName.ListCount - 1)
    BDel.Enabled = LName.ListCount > 0
End Sub

'テキストの内容から追加ボタンが有効/無効の状態を変更します
'TODO:""を許すとか，重複もありとかの初期設定があってもいいのかもしれない
Private Sub TName_Change()
    Dim fHas As Boolean
    If Trim(TName.Text) = "" Then
        'テキストに何も入っていなければついあする必要はないので追加ボタンは無効にする
        BAdd.Enabled = False
        Exit Sub
    End If
    'リストのアイテムを検索して，テキストと同じものが含まれていた場合は追加できないので追加ボタンを無効にする
    For i = 0 To LName.ListCount - 1
        If Trim(TName.Text) = LName.list(i, 0) Then
            'リストの中に同じ文字列が存在していればボタンを無効にする
            BAdd.Enabled = False
            Exit Sub
        End If
    Next
    BAdd.Enabled = True
End Sub

'フォームの初期状態を設定します
Private Sub UserForm_Initialize()
    '各ボタンの状態を設定する
    BAdd.Enabled = False
    BUp.Enabled = False
    BDown.Enabled = False
    BDel.Enabled = False
    RetCode = vbCancel
End Sub

'=================================================================================================
'外部から呼び出す関数．これに指定した名前を表示し，OKボタンでクローズされた場合は，編集した結果を反映する．
Function EditName(n As Name, captionText As String) As Long
    Dim r As Range
    Set r = n.RefersToRange
    Dim c
    'リストに初期値を設定する
    For Each c In r.Cells
        If Trim(c.Value) <> "" Then 'Trimして""なら追加しない
            LName.AddItem Trim(c.Value)
        End If
    Next
    caption = captionText
   
    Show
    If RetCode = vbOK Then
        '終了のコードがOkの場合
        r.Value = "" 'ここでもと情報を削除
        Dim strWork As String
        Dim i
        For i = 0 To LName.ListCount - 1
            '現在のリストの内容をもともとの位置に入れていく
            r.Worksheet.Cells(r.Row + i, r.Column) = Trim(LName.list(i, 0))
        Next
        Dim strName As String
        Dim NewRange As Range
        Dim BottomRow As Integer
        If LName.ListCount = 0 Then 'ひとつも情報がない場合はあきでもいいので設定する．
            BottomRow = r.Row
        Else
            BottomRow = r.Row + LName.ListCount - 1
        End If
        Set NewRange = r.Worksheet.Range(r.Worksheet.Cells(r.Row, r.Column), r.Worksheet.Cells(BottomRow, r.Column))
        strName = n.Name
        n.Delete
        ActiveWorkbook.Names.Add strName, NewRange
    End If
    ShowForm = RetCode
End Function

使い方は
a) まず名前を設定します．
適当に範囲を選択して，数式->名前の管理->新規作成
b) この名前を編集するためのマクロを作ります
EditStatusをコピーしてststusと書いてあるところをひとつ前で作った名前に変更します．
c) このマクロを動かすためのボタンを作ります
開発->挿入->ボタンでどこかにボタンを追加します．
ボタン上で右クリックして，さっき追加したマクロを選択します．
※リボンのユーザ設定で開発を追加しておいてください．

d)ボタンを押してフォームの動作を確認します

あとは実際に選択する場所です．

2,名前から選択する

ボタンを押されたときの処理は

Sub SelectItems(strName As String, r As Range, title As String)
    Dim frm As ListSelectForm
    Set frm = New ListSelectForm
    Dim n As Name
    Set n = ThisWorkbook.Names(strName)
    If frm.SelectItems(r, n, title, False) = vbOK Then
        Debug.Print "何かやることがあるなら"
    End If
End Sub

'特定のセルでダブルクリックされたときに次の動作を行う
'(2,4):statusを選択する
'(2,5):operationを選択する
'コンテキストメニューだと消すときとかいろいろ面倒なことになるのでダブルクリックが一番よさげ
'キーボード操作に対応するならSelchangeなのかも，でもうっとうしいんじゃないか
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.Row = 2 And Target.Cells.Column = 4 Then
        SelectItems "status", Target.Cells, "statusの選択"
        Cancel = True
    ElseIf Target.Cells.Row = 2 And Target.Cells.Column = 5 Then
        SelectItems "operation", Target.Cells, "operationの選択"
        Cancel = True
    End If
End Sub

フォームの処理は

'Copyright (c) 2011 Yuji OKAZAKI. All rights reserved.
'
'Redistribution and use in source and binary forms, with or without modification, are permitted provided
'that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this list of conditions and
'   the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
'   and the following disclaimer in the documentation and/or other materials provided with the
'   distribution.
'
'THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
'INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
'A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE
'FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
'NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
'OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
'STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
'THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Public RetCode As Integer

Private Sub BCancel_Click()
    Unload Me
End Sub

Private Sub BOK_Click()
    RetCode = vbOK
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    RetCode = vbCancel
End Sub

'名前で指定された内容をリストに表示し，指定した場所の内容で選択したリスト
'のあるダイアログを表示して選択させその結果を指定位置に埋め込む
Function SelectItems(rRet As Range, n As Name, title As String, SetValidate As Boolean) As Long
    Dim strSelected As String
    strSelected = rRet.Value
    Dim r As Range
    Set r = n.RefersToRange
    Dim frm As ListSelectForm
    Set frm = New ListSelectForm
   
    Dim col
    Dim sel As Collection
    Set sel = New Collection
    col = Split(strSelected, ",")
    Dim selectedItemText
    For Each selectedItemText In col
        selectedItemText = Trim(selectedItemText)
        sel.Add selectedItemText, selectedItemText
    Next
   
    'リストに内容を入れていく
    Dim c
    For Each c In r.Cells
        Dim work
        work = ","
        On Error Resume Next
        work = sel.Item(c.Value)
        On Error GoTo 0
        frm.LName.AddItem (c.Value)
        If work <> "," Then
            '指定された選択項目に追加した文字列が存在した場合はリストの項目を選択する
            frm.LName.Selected(frm.LName.ListCount - 1) = True
        End If
    Next
    frm.caption = title
    frm.Show
    If frm.RetCode = vbOK Then
        strSelected = ""
        Dim strWork As String
        For i = 0 To frm.LName.ListCount - 1
            If frm.LName.Selected(i) Then
                If strSelected <> "" Then
                    strSelected = strSelected + ","
                End If
                strSelected = strSelected + Trim(frm.LName.list(i, 0))
            End If
        Next
    End If
    SelectItems = frm.RetCode
    If frm.RetCode = vbOK Then
        If SetValidate = True Then
            If InStr(1, strSelected, ",") > 0 Then
                rRet.Validation.Delete
            Else
                rRet.Validation.Add Type:=xlValidateList, Formula1:="=" & n.Name
            End If
        End If
    End If
    rRet.Value = strSelected
End Function

こんな感じですのでxlsmファイルを添付しておきます

「Table.zip」をダウンロード

今日はさすがによっているみたいなので，間違っていたら指摘してください．