『入力規則のリストに追加』（なっち）

 こんにちは、お邪魔します。
 
 過去ログでお見かけした、『入力規則』（ポー）さんと同じような事をしたいのですが・・・
 回答されていた、ケンさん、SoulManさんのプログラムに少し複雑な動作を追加したい
 のです。
 VBAはまったくの初心者で、マクロの自動記録しか使用したことがありません。
 もし、私の希望する動作が可能であれば、教えて頂けないでしょうか・・・

 
 現在、私が作成しているもの（予算書なのですが）では、入力規則のリストが
 複数シートの複数範囲(シート13枚に４つの同じ表のがあり、B列の4つの範囲)
 に設定してあり、そのリストから品物を選択すると別の列(I列)に単価が表示される。
 リスト範囲は別シートに(リスト一覧、としています)作成し、品数が多いので
 五十音別に列を分けて、各品物の隣列に単価も入力してあります。
 リストの表示は、品物の頭文字を打つと、その頭文字のつく品物が選択できるように
 なっています。(リストの設定などは全てこちらで教わった方法です)
 
 希望する動作は、
 複数シートの複数範囲に設定しているリストのセルのどこからでも、リストにない
 品物を直接入力でき、入力すると五十音列別になっているリスト一覧シートの該当
 する列に追加され、品物の単価も一緒に追加できる。
 
 このような事は難しいのでしょうか・・・？

 作成しているもののレイアウトの仕方が問題であれば、作り直したいと思いますので
 教えて頂けませんか・・・
　(なっち)
----
 こちらですね
[[20050425224445]]『入力規則』（ポー） 
ぱっとみですが
 >五十音別に列を分けて、
これが難しいと思います。
リストにないものを追加していくだけでしたら簡単です。
現在のサンプルの既にそうなってます。
リストにないものを追加して並び替えるならほとんどマクロの記録で
出来ると思います。
ただ、
 >品物の単価も一緒に追加できる。
これがよくわかりません。
とりあえずこんな感じでどうでしょうか？
（SoulMan）
 
----
  
 ご回答ありがとうございます。
 すみません、SoulManさんのサンプルを試したのですが、リストに追加出来るセルが
 D1セルのみになっているようなので(入力規則のリストを下方向にコピーしてみた
 のですが)
 これを、入力規則のリストが設定されている複数のセルからでも行えるようにした
 いのです。
 しかし・・・五十音別に・・やはり無理ですか・・・(T_T)
 >品物の単価も一緒に追加できる。
 説明不足で申し訳ありません
 これは、"この名前をリストに追加しますか？"のメッセージボックスが現れたとき
 同時にというか一緒のボックスに"単価も入力してください"のようなメッセージと
 単価を入力するフォームのようなものが現れ、追加出来る。
 というような感じです。

 また、
 >リストにないものを追加して並び替えるならほとんどマクロの記録で・・・
 現在のリスト範囲のシートは、
 B列から横方向にあ列、単価列、い列、単価、列う列、単価・・・と並んでいます。
 このような場合でもマクロの記録で対応できるのでしょうか
 教えて頂けませんか？
 (なっち)
----
 こんにちは！
 >入力規則のリストを下方向にコピーしてみた のですが)
 これは変数を一つ用意してTargetの中をループすればいいと思います。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim LastR As Long
Dim MyStr As String
Application.EnableEvents = False
    With Worksheets("Sheet2")
    For Each r In Target
        If r.Value <> "" Then
            LastR = .Range("A36636").End(xlUp).Row
            Set c = .Range("A1:A" & LastR).Find( _
                    r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
            If c Is Nothing Then
                If vbYes = MsgBox("この名前をリストに追加しますか？", _
                    vbYesNo, "名前の追加の確認") Then
                    MyStr = InputBox("単価を入力してください。")
                    If MyStr <> "" Then
                        .Range("A" & LastR + 1).Value = r.Value
                        .Range("B" & LastR + 1).Value = MyStr
                        .Range("A1:A" & LastR + 1).Name = "リスト"
                        With Target.Validation
                            .Delete
                            .Add Type:=xlValidateList, Formula1:="=リスト"
                            .ShowError = False
                        End With
                    End If
                End If
            End If
        End If
    Next r
    End With
Application.EnableEvents = True
End Sub
 >"単価も入力してください"のようなメッセージと
 >単価を入力するフォームのようなものが現れ、追加出来る。
 >というような感じです。
 これはインプットボックスのことだと思いますが、コードを作る時間があって
 シートの 最下部に追加していくかたちでしたら、わりと簡単だと思います。
 >このような場合でもマクロの記録で対応できるのでしょうか
 これが
 >作り直したいと思いますので
 これに該当するわけですが、
 どのようにして現在のリストを使用されているのかがわかりませんが 
 見出しがあってそのリストの最下部に追加してから五十音順で並び替えるというご提案です。
（正確には並び替わらないかもしれませんが。。。）
 リストは一列というか二列・三列でもいいのですがデータベースであって欲しいのです。つまり
 >五十音別に列を分けて、
 これが難しくなるのです。  
 どうでしょうか？
 手間暇をかければいいものは出来ます。出来ると思います。
 ここで質問すればどなたかが作ってくれるかもしれません。が、 
 大切なことは現在のご自身の力で対応出来るところは対応するということです。 
 どうでしょうか？
2005/4/27　14:20
空白でフィルした時も反応するので条件を一つ追加しました。
少し落ち着いたので満足のいくものではないでしょうが、
インプットボックスを使ったものにしてみました。
AB列に順番に登録していきます。
後はこれを応用していかれたらいいと思いますがどうでしょうか？
2005/4/27　16:00
（SoulMan）
----
 SoulManさんすみません！お返事がおそくなりましたm(__)m
 お忙しいのに・・こんなに親切に対応して下さって感謝しています。
 単価の追加まで対応して下さり、本当に涙が出そうです。
 ありがとうございます。とても満足しています。
 このプログラムを応用して、手間をかけなんとか良いものを作りたいと思っています。
 
 コードに書かれている事の理解に苦しんでおりますが、まず、リストに追加された
 後の並び替えを考えたいと思います。
 ちなみに
 >リストは一列というか二列・三列でもいいのですがデータベースであって欲しいのです。
 これは、B列→CM列までで90列あります。 　
 　　　B　    　C      D    　 E　　　　     　 CL     CM　　　
 　1　あ　   単価列   い　　 単価列　・・・→  わ　  単価列
 　2　あ1　　 100　　 い1     150　　　　　　  わ1　　200
　 3　あ2　　 110　　 い2　　 500　　　　　　  わ2　　300
 このようになっているんですが、データベース？とは呼ばないのでしょうか・・・
 　　(なつち)　
----
 うぅ〜〜ん、即興ですよ。正直いってあまり良い出来じゃないです。
とりあえずヒントだけって感じです。
振りわけをターゲットの値からとることも考えましたが汎用性が低いので
ユーザーに選択させる形にしてみました。
どうでしょうか？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim LastR As Long
Dim MyStr As String, ふりがな As String
Dim x As Variant
Application.EnableEvents = False
    With Worksheets("Sheet2")
    For Each r In Target
        If r.Value <> "" Then
            Set c = .Cells.Find( _
                    r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
            If c Is Nothing Then
                If vbYes = MsgBox("この名前をリストに追加しますか？", _
                    vbYesNo, "名前の追加の確認") Then
                    ふりがな = InputBox("ふりがなを入力してください。")
                    If ふりがな <> "" Then
                    x = Application.Match(ふりがな, .Range("A1:IV1"), 0)
                        If Not IsError(x) Then
                            MyStr = InputBox("単価を入力してください。")
                            If MyStr <> "" Then
                                LastR = .Cells(65536, x).End(xlUp).Row
                                .Cells(LastR + 1, x).Value = r.Value
                                .Cells(LastR + 1, x + 1).Value = MyStr
                                .Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
                                With Target.Validation
                                    .Delete
                                    .Add Type:=xlValidateList, Formula1:="=リスト" & x
                                    .ShowError = False
                                End With
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next r
    End With
Application.EnableEvents = True
End Sub
（SoulMan）

----
 SoulManさん、ありがとうございます。
 即興ですか・・・・(@_@)凄いです・・・
 
 えっと・・・すみません↑のプログラムを実行するにあたって、シート側で
 設定しなくてはならない事がありますか？　
 マヌケな質問ですみません(T_T)
 (なっち)
----
 えぇ〜〜っと、、、Sheet2に
なっちさんが書いている様なリスト？がないといけませんね。
一応一行目を検索の対象にしています。
後は、Sheet1も実行する範囲を制限したりと、、色々したいことはあるけど、、
とりあえず・・・です。
（SoulMan）

----
 SoulManさん、凄いです。夢のようです。見事に振分けされ単価も入ります。
 ありがとうございます。m(__)m
 マヌケな質問にもわかり易く答えて下さって感謝しますm(__)m
 
 すいません！ちょっと不思議な現象が起こってるんです・・・？？？
 私の設定ミスだと思うので頭を整理してから質問します！
 質問は明日にします・・・
 SoulManさん、今日一日ありがとうございましたm(__)m
　　(なっち)
 
----
 お久しぶりです、SoulManさん．．．
 とても親切にして頂いて、そのまま質問もできず連休に入ってしまい申し訳なく
 思っています。
 連休前の↑の時は少しパニックになっていたようです。すみませんm(__)m
 もし、お時間があれば、また教えて頂きたいのですが・・・
 >ちょっと不思議な現象が・・・
 について質問したいのですけど・・・
　　（なっち）
----
 えっ？改まっていわれると緊張するけど、私で分かる範囲でよければ
お答えしますよ。どんな現象でしょうか？
（SoulMan）

----
 お返事ありがとうございます！！m(__)m
 すみません・・・緊張なんてなさらないで下さい。
 
 不思議な現象
 �@リストに名前・ふりがな・単価を追加した後、追加を行ったセル(仮にB5だったら)
   の入力規則のリストの「元の値」が 「=INDIRECT(B5)」から「=リスト2」に変わってしまう
   (追加する度にリスト3とか、リスト10などと変わっていく。数字は飛数？のようです)
 �Aその結果、リストから選択し直そうとした時、そのセルは
 　追加した名前のふりがなのリストしか表示されない
 　(例えば、B5で「あめ」と追加した場合、あっ！間違った本当は「か」のつくものを
 　選びたかったんだ・・となって「か」から選択しようとしても「あ」のつくもの
 　からしか選択できなくなる)

 こなん感じの現象なんですけど・・・
 私の設定がいけないのでしょうか・・・
 教えて下さい。
　　(なっち)
----
 こんばんは！
 それは不思議な現象でも何でもなくて
 .Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
 With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=リスト" & x
    .ShowError = False
 End With
 この部分で名前を付けているからなんですが、、、、
 .Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
 >元の値」が 「=INDIRECT(B5)」から「=リスト2」に変わってしまう
 このxの部分が
 x = Application.Match(ふりがな, .Range("A1:IV1"), 0)
 で取り出した列の位置です。
 =リスト2
 と表示されるのは左から2番目ですから「B」列ではありませんか？
 >数字は飛数？のようです
 というのは
 B　    　C      D    　 E　　　　     　 CL     CM　　　
 1　あ　   単価列   い　　 単価列　・・・→  わ　  単価列
 2　あ1　　 100　　 い1     150　　　　　　  わ1　　200
 3　あ2　　 110　　 い2　　 500　　　　　　  わ2　　300
 の様に「ふりがな」「単価」と並んでいるからで、、ふりがなの隣は単価ですから
 飛び飛びになるのです。わかりますか？
 >「元の値」が 「=INDIRECT(B5)」
 この元の値にどんな値が入っているのかわかりませんが、
 つまり
 B5にはどんな値が入っているのですか？
 この辺の運用がいまいち理解してないのでちょっとわかりかねますが、
 >その結果、リストから選択し直そうとした時、そのセルは
 >追加した名前のふりがなのリストしか表示されない
 は、当然のことでその様にしているのです。
 ちょっとちんぷんかんぷん？ですね(^^;
あぁ、、ひょっとして入力規則は既に設定してあって
追加する必要はないのですね？
それでしたら、↓この部分を削除するか、コメント化すれば
入力規則を新たに設定することはありませんよ。
.Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
 With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=リスト" & x
    .ShowError = False
 End With
どうでしょうか？
（SoulMan）
----
 お返事ありがとうございます 
 すみません、不思議な現象ではない、という事はわかりました(*_*)
 >表示されるのは左から2番目ですから「B」列ではありませんか？
 >の様に「ふりがな」「単価」と並んでいるからで、、ふりがなの隣は単価ですから
 飛び飛びになるのです。わかりますか？
 これはとても分かり易い説明で、理解できました。
 
 >B5にはどんな値が入っているのですか？
 ここには、入力規則のリストが設置してありますが、リストの参照範囲は別シート
 (Sheet2)なのでリスト範囲に名前を付け、「元の値」を 「=INDIRECT(B5)」と
 しています。
 そしてリストから選択する時に、頭文字を打つと、その分だけリストに表示され選択
 できるようになっています。
 んっ？こんな事を聞かれているのではないのですか？(*_*) 
 もし、とんちんかんな返答でしたら、申し訳ありませんが指摘して下さいm(__)m
 
 >当然のことでその様にしているのです。
 これは、選択し直したい時に問題になってしまいます(T_T)
 なんとか解決したいのですが・・・
　(なっち)
 衝突してしまいました。
 先に解決法を提示して頂いているみたいですね、ありがとうございます。
 まずは取り急ぎ、試したいと思います！
 (なっち)
----
 それではとりあえず
この部分を
.Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
 With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=リスト" & x
    .ShowError = False
 End With
以下に変更してみてください。
On Error Resume Next
    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & r.Address(0, 0) & ")"
        .ShowError = False
    End With
On Error GoTo 0
そのB5というかぁ、、その値の名前が定義されていないとエラーになるので
On Error Resume Next
でエラーをトラップしています。
どの様にして名前が追加されていくのかが不明ですが、これで
B5で実行すれば
=INDIRECT(B5)
A3で実行すれば
=INDIRECT(A3)
となるでしょう。
どうでしょうか？
あっ、すみません。やっぱり、これはおかしい？ですよねぇ？？
リストにないから追加するのにその名前があるわけないですよねぇ？？？
やっぱりこの部分は不要なのかな？？
あっ、最初の方でFor　Each　しているのを忘れていましたので式の部分を変更しました。
"=INDIRECT（" & r.Address(0, 0)
でも、どっちみち変ですが、結果待ちします。
（SoulMan）

----
 すみません、書き忘れました。入力規則のリストは既に設定してあります。
 On Error Resume Next
    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & Target.Address(0, 0) & ")"
        .ShowError = False
    End With
On Error GoTo 0

 これ↑に変更したら
 追加を行ったセルの入力規則が消えてしまうんです(T_T)
 追加したものは、ちゃんと別シートのリスト範囲に単価と一緒に五十音別に振り分け
 されているのに・・・(T_T)

 先に提示して頂いた
 .Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = "リスト" & x
 With Target.Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=リスト" & x
    .ShowError = False
 End With
 ↑を削除する方法では 入力規則は消えないのですが、追加した名前はリスト表示
 されません(T_T)別シートのリスト範囲にはちゃんと追加されているのですが・・

 お忙しいのに、いろいろと考えて下さっているのに申し訳ないです。
 すみませんm(__)mなんだか、ややこしくなってしまいましたか？
 なんとか解決したいです(>_<)
 　(なっち)
 あっ、また 衝突しました！
 追記されていた式の変更もしてみましたが、結果は同じみたいです・・・(T_T)
 もう内容が上級者過ぎて、ただただ提示された事を実行しているだけになってますが
 なんとかお付き合い下さいm(__)m
 今後の為にも勉強したいです。
 (なっち)
----
 そのもともとある名前の定義の式はどんな式ですか？
=INDIRECT(B5)
（SoulMan）　
 
----
 すみません、 
 >そのもともとある名前の定義の式はどんな式ですか？
 =INDIRECT(B5)
 どんな式？といわれましても・・えっと・・・(＠_＠;)
 よく分からないのです・・
 低レベル過ぎて大変申し訳ありません！！m(__)m
 名前の定義の式・・ですよね・・・少し調べてみます。
 (なっち)
----
 横から失礼します。新と申します。
 =INDIRECT(B5)　は、B5に入力規則でリストとしてあ,い,う,・・・,わ
 が設定してあり
 Sheet2のA:Aのセル範囲に名前として「あ」が付されていると思われます。
 間違っていたらなっちさんご免なさい。
 この問題に非常に興味のある新です。

----
 こんばんは、新さん？(゜o゜)
 はい、たぶんそうです！入力規則を設定しているセルはB5だけではありませんが、
 「あ」とか「う」とか一文字打つと「あ」のつくもののリスト「う」のリストが
 表示できるようになってます。
 >Sheet2のA:Aのセル範囲に名前として「あ」が付されていると思われます。
 Sheet2(リスト一覧としています)
 正確にはB:1が「あ」です
　(なっち)
----
 ちょっとよくわかりませんが、以下でどうでしょうか？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim LastR As Long, i As Long
Dim MyStr As String, ふりがな As String
Dim x As Variant
Dim MyFlag As Boolean
Application.EnableEvents = False
    With Worksheets("Sheet2")
        For Each r In Target
            If r.Value <> "" Then
                Set c = .Cells.Find(r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
                    'Findで検索してなかったら
                    If c Is Nothing Then
                        If vbYes = MsgBox("この名前をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                            ふりがな = InputBox("ふりがなを入力してください。")
                                'ふりがなが入力されたら
                                If ふりがな <> "" Then
                                    'その名前が定義されているか調べます。
                                    For i = 1 To ThisWorkbook.Names.Count
                                        If ふりがな = ThisWorkbook.Names(i).Name Then MyFlag = True: Exit For
                                    Next
                                        '名前が定義されていたら
                                        If MyFlag Then
                                            'ループの為にフラグを初期化します。
                                            MyFlag = False
                                            'Matchで列を求めます。
                                            x = Application.Match(ふりがな, .Range("A1:IV1"), 0)
                                            '列があったら（エラーじゃなかったら）
                                                If Not IsError(x) Then
                                                    '単価を要求します。
                                                    MyStr = InputBox("単価を入力してください。")
                                                    '単価が入力されたら
                                                    If MyStr <> "" Then
                                                        LastR = .Cells(65536, x).End(xlUp).Row
                                                        .Cells(LastR + 1, x).Value = r.Value
                                                        .Cells(LastR + 1, x + 1).Value = MyStr
                                                        '追加された範囲に「ふりがな」入力時に入力された名前を定義します。
                                                        .Range(.Cells(1, x), .Cells(LastR + 1, x)).Name = ふりがな
                                                    End If
                                                Else
                                                    MsgBox ふりがな & "は、ありません"
                                                End If 'ｘ
                                        Else
                                            MsgBox ふりがな & "は定義されていません。"
                                        End If 'MyFlag
                                End If 'ふりがな
                        End If 'MsgBox
                    Else
                        'その名前が定義されているか調べます。
                        For i = 1 To ThisWorkbook.Names.Count
                            If r.Value = ThisWorkbook.Names(i).Name Then MyFlag = True: Exit For
                        Next
                        '名前があったら
                        If MyFlag Then
                            'ループの為にフラグを初期化します。
                            MyFlag = False
                            '選択された範囲の入力規則を一旦消去して
                            '"=INDIRECT（" & r.Address(0, 0) & ")"を入力します。
                            With r.Validation
                                .Delete
                                .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & r.Address(0, 0) & ")"
                                .ShowError = False
                            End With
                        End If
                    End If 'Find
            End If '空白の判定
        Next r
    End With
Application.EnableEvents = True
End Sub
失礼！フィルした時にうまくいかなのでちょっと修正しました。
それから、実行範囲を制限した方がよくありませんか？
（SoulMan）

----
 すみませんm(__)mこんな夜分遅くに・・・
 SoulManさん、コメントまで入れて頂きありがとうございます！(凄い長くなっていてビックリ(@_@)しました)
 勉強できそうです。
 ↑の試しましたが・・・追加ができなくなってしまいました・・・
 メッセージボックスが現れないんです(T_T)
 >それから、実行範囲を制限した方がよくありませんか？
 この実行範囲とはどうゆう事ですか？
 本当に低レベルですみません、、、、
 お返事は明日でもあさってでも問題ありません
 宜しくお願いしますm(__)m
 (なっち)
----
 簡単なサンプルです。
 右クリック→対象ファイルを保存してからお試しください。
 使用範囲も制限されています。
 >この実行範囲とはどうゆう事ですか？
 着色された部分のみで有効です。
 一応「あ、い、わ」という名前を付けています。
 >追加ができなくなってしまいました・・・
 入力規則に
「=INDIRECT(B5)」
 の式を使っているので
 定義されていない名前を入力すると入力規則は
 表示されませんよね？
 とりあえず
「あ」とか「い」とか「わ」とか入力してみてください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0305.xls
（SoulMan）
----
 朝、起きてよく考えたら、一度、変数に代入しておけばいいんですよね。
で、入力規則をセットしてからその変数を元に戻してあげればいいんですね。
長くなってしまいましたが、以下でどうでしょうか？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim MyRow As Long
Dim 単価 As Variant, 名前 As Variant, MyData As String
Dim x As Variant, MyName As Name
Dim MyFlag As Boolean
'実行範囲を制限します。
If Intersect(Target, Range("A1:E10")) Is Nothing Then Exit Sub
'イベントを無効にします。
Application.EnableEvents = False
    With Worksheets("Sheet2")
        'For　Each　でTargetをループします。
        For Each r In Target
            'rが空白じゃなかったら
            If r.Value <> "" Then
                '変数MyDataに代入します。
                MyData = r.Value
                'Findで検索します。
                Set c = .Cells.Find(r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
                    'Findで検索して無かったら
                    If c Is Nothing Then
                        'MsgBoxを表示してYesだったら処理をします。
                        If vbYes = MsgBox(MyData & "　をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                            名前 = Application.InputBox("名前を入力してください。", Type:=2)
                            '名前が入力されたら
                                If TypeName(名前) <> "Boolean" And 名前 <> "" Then
                                    'その名前が定義されているか調べます。
                                    For Each MyName In ThisWorkbook.Names
                                        If MyName.Name = 名前 Then MyFlag = True: Exit For
                                    Next
                                    '名前が定義されていたら
                                    If MyFlag Then
                                    'ループの為にフラグを初期化します。
                                    MyFlag = False
                                    'Matchで列を求めます。
                                    x = Application.Match(名前, .Range("A1:IV1"), 0)
                                    '列があったら（エラーじゃなかったら）
                                        If Not IsError(x) Then
                                            'MsgBoxで単価の入力を確認し、Yesだったら要求します。
                                            If vbYes = MsgBox("単価を入力しますか？", vbYesNo) Then
                                                '単価を要求します。
                                                単価 = Application.InputBox("単価を入力してください。", Type:=1)
                                            End If '単価MsgBox
                                                '単価の入力がキャンセル以外だったら
                                                If TypeName(単価) <> "Boolean" Then
                                                    MyRow = .Cells(65536, x).End(xlUp).Row
                                                    .Cells(MyRow + 1, x).Value = r.Value
                                                    .Cells(MyRow + 1, x + 1).Value = 単価
                                                    '追加された範囲に「名前」入力時に入力された名前を定義します。
                                                    .Range(.Cells(1, x), .Cells(MyRow + 1, x)).Name = 名前
                                                    'このままでは入力規則が設定出来ないので一旦r.Valueに名前を代入します。
                                                    r.Value = 名前
                                                    '選択された範囲の入力規則を一旦消去して
                                                    '"=INDIRECT（" & r.Address(0, 0) & ")"を入力します。
                                                    With r.Validation
                                                        .Delete
                                                        .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & r.Address(0, 0) & ")"
                                                        .ShowError = False
                                                    End With
                                                    '.ShowError = Falseでエラーをトラップしたのでr.ValueにMyDataを代入します。
                                                    r.Value = MyData
                                                    'ふりがなに名前を代入します。
                                                    r.Characters.PhoneticCharacters = 名前
                                                End If '単価
                                        Else
                                            MsgBox 名前 & "　は、ありません"
                                        End If 'ｘ
                                    Else
                                        MsgBox 名前 & "　は定義されていません。"
                                    End If 'MyFlag
                                End If '名前
                        End If 'MsgBox
                    End If 'Find
            End If '空白の判定
            'ふりがなを設定します。
            r.SetPhonetic
        Next r
    End With
'イベントを有効にします。
Application.EnableEvents = True
End Sub
（SoulMan）
----
 お返事が遅くなり申し訳ありません！
 ありがとうございます！！m(__)mm(__)mm(__)m
 凄いです！！本当に感謝感激です！
 
 ここまで親切にして頂いて大変恐縮なんですが、、、、
 すみません(>_<)もう少し教えて下さいm(__)m
 
 Input Boxの大きさは変えられないものなのですか？
 もし不可能でしたら、あの、、なんて呼ぶのか分からないんですけど(すみません)
 ふりがなや単価を入力する所だけでも短くできないのでしょうか？
 また、単価の入力時だけ自動で半角英数入力にする事は難しいのですか？
 Input Boxの作成方法も知りたいです。
 ユーザーフォームとはまったく違うものですか？
 (なっち)　
----
 >Input Boxの大きさは変えられないものなのですか？
 InputBoxメッソドを使うと若干小さくなります。
 Typeも指定出来ます。
 Type1が数値で単価に使用します。
 Type2が文字列で名前に使用します。
 ただキャンセルを押した時の判定がInputBox関数とは異なるので
 変数をVariant型で宣言して
 Dim 単価 As Variant, 名前 As Variant, MyData As String
 TypeName関数で調べるのが一般的です。
 If TypeName(名前) <> "Boolean" And 名前 <> "" Then
 とか
 If TypeName(単価) <> "Boolean" Then
 とかです。
 >ユーザーフォームとはまったく違うものですか？
 全然関係ありません。
 上のコードは修正しておきました。
 >Input Boxの作成方法も知りたいです。
 こちらがいいと思います。
http://www.moug.net/skillup/nksw/nksw06-01.htm
http://www.sanynet.ne.jp/~awa/excelvba/kouza/chapt_03/004.html
http://t_shun.at.infoseek.co.jp/My_Page/Excel-VBA/vba_page22.htm
（SoulMan） 
 
----
 SoulManさん、ありがとうございますm(__)m
 Input Boxの勉強サイトも教えて下さりありがとうございます。
 頼りっぱなしになってしまい本当に心苦しいのですが・・・
 あの、、、もう一つお願いしたいんです(>_<)
 名前を追加する時に単価がすぐに分からない場合があるんです・・・
 頻繁にあるわけではないのですが、この場合に、単価を未入力のまま
 名前とふりがなだけはリストに追加できようにしたいのです・・・
 
 原状では単価を未入力でOKボタンを押すと、"入力した数式は正しくありません"
 と警告みたいなものが出るんですけど・・・
 
 可能であれば、単価を未入力でOKボタンを押した場合、
 "単価が入力されていませんがあとで単価表に手入力しますか？"
 のようなメッセージが出て、名前はリストへ追加できる。
 このような事は無理でしょうか？
 　(なっち)
----
 上のコードを修正しておきました。
差分で修正個所を確認出来ますから違いを確認しておいてくださいね。
（SoulMan） 
----
 SoulManさん、すみません！大変おそくなりましたm(__)mありがとうございますm(__)m
 休日の深夜にもかかわらず編集して下さっていて大変申し訳なく思っています・・・
 差分で修正箇所の確認(親切に教えて下さり感謝ですm(__)m)をして勉強中なのですが、
 また、新たに問題が起きてしまいました(T_T)
 お世話になりっぱなしで大変恐縮なんですが 、漢字から始まる名前とアルファベット
 から始まる名前を追加した場合、単価が表示されないのです・・・
 私なりにいろいろと調べたのですが、追加した後一つ一つふりがな編集するしかない
 のでしょうか・・・
 他に方法があるのでしょうか？
 (なっち)
----
 えぇ〜〜っと、いまいちイメージがわかないんだけど、
 単価が表示されないということは
 >'Matchで列を求めます。
 >x = Application.Match(名前, .Range("A1:IV1"), 0)
 >'列があったら（エラーじゃなかったら）
 >If Not IsError(x) Then
 >'MsgBoxで単価の入力を確認し、Yesだったら要求します。
 「ｘ」がエラーってことですよね？
 「学校」と入力して 
 名前を「い」としたら
 「い」の列に入りますけど、、？
 >追加した後一つ一つふりがな編集するしかない のでしょうか・・・
 どの様な運用の仕方をされているのか具体的に教えて頂けませんか？
（SoulMan） 
----
 すみません！また遅くなり申し訳ありませんm(__)m
 お忙しいのにお付き合い下さりありがとうございます。
 申し訳ありませんm(__)m
 私の質問が、どうやらSoulManさんに教えて頂いてる部分から外れていたようです・・
 >単価表示されない
 の問題の中身は、現在
 シート2にリスト一覧があり、ここにシート1で追加した名前と単価が入ってきます
 SoulManさんに作って頂いたプログラム通りです。
 シート1のB列に入力規則を設置して、I列に単価を表示させているのですが
 そのI列に単価表示されない、という事だったのです・・・
 ですので、シート2のリスト一覧にはちゃんと名前も単価も追加されていくんです。
 
 ちなみにシート1のI列には(I3セルでいうと)
 I3=IF(ISERROR(VLOOKUP(B3,OFFSET(リスト一覧!$B$1,1,MATCH(LEFT(PHONETIC(B3),1),リスト一覧!$B$1:$CM$1,0)-1,30,2),2,FALSE)),"",VLOOKUP(B3,OFFSET(リスト一覧!$B$1,1,MATCH(LEFT(PHONETIC(B3),1),リスト一覧!$B$1:$CM$1,0)-1,30,2),2,FALSE))
 このような式が入っています。
 
 あらかじめリスト一覧にあって、単価が表示されなかったものには(英字とカタカナで
 始まるものだたったんですけど)ふりがなの編集をして表示されるようにできたのです
 が、SoulManさんに作って頂いたプログラムで追加した、漢字と英字で始まる名前は
 I列に単価が表示されないのです・・・
 追加した後にリスト一覧とシート1両方でふりがな編集すると(名前の先頭文字をダブ
 ルクリックして右クリック→ふりがなの編集(E)→Enter。英字の場合は、アルファベ
 ットをひらがなに編集しました 「B」なら「びー」 のように・・)
 >追加した後一つ一つふりがな編集するしかない のでしょうか
 これは、その為の質問でした。
 
 プログラムに問題があるのではないのです。言葉足らずで誤解を招いてしまい
 申し訳ありませんでしたm(__)m
 もし解決法がありましたら、教えて頂けませんか(T_T)
 (なっち)
----
 ふりがなの情報がないってことかな？？
Range("A:A").SetPhonetic
こんなコードを実行してみるといいと思います。
（SoulMan） 
----
 回答ありがとうございます！m(__)m
 すみません、、、
 ↑のコード実行、、、どこにどのように書けば良いですか？
 そなんことさえまだ理解できていません・・・
 (なっち) 
----
 上のコードに追加しておきました。
（SoulMan） 
----
 何度も申し訳ありません・・・
 追加されたコードを試したのですが、
 漢字・・・追加作業の後、再び入力規則のリストで選択し直さなければ単価表示
           されないです。
 英字・・・追加作業の後、やはり、リスト一覧でふりがな編集をしなければ単価表示
           できないです。
 エクセルの仕様に限界があるのでしょうか・・・・(T_T)
 (なっち)
----
 あぁ、、すみません。
ふりがながないのはSheet1なのですね？
修正しておきましたから、お試しください。
（SoulMan）
----
 あっ、わかりました。
登録した文字のふりがなに入力の時に使った「名前」をセットしたいのですね？？？
そういえば、初めから五十音順とか仰ってましたねぇ？？？
上のコードを修正しておきましたので、お試しください。
今度は、、、OKでしょう？？？自信ありv(=∩_∩=)v
（SoulMan）
----
 m(__)mm(__)mm(__)mありがとうございます！！！m(__)mm(__)mm(__)m
 SoulManさん、本当にありがとうございます！！！
 完璧です(ToT)
 なんとお礼を言っていいか・・・本当にありがとうございます。
 理解して頂けるような説明をできなくて本当に恥じております・・・m(__)m
 私のような者に、貴重なお時間を沢山使って下さり、感謝の気持ちでいっぱいです。
 
 あっ！もう一つだけ宜しいでしょうか・・・
 新たにシートを挿入して(シート3とします)シート3にもこのコードを貼り付けら
 今のところ、問題なく動いてくれるのですが、このような使い方は適切ではないので
 しょうか・・・
 (なっち)
----
 >このような使い方は適切ではないのでしょうか・・・
 別に問題ないと思いますけど・・？
 それから、私は、いつもここにいますからね。
 また、わからないことがあったら、いつでも気軽に聞いてください。
 私でわかることならお答えしますので、、(^^;
 >理解して頂けるような説明をできなくて
 難しいですよねぇ。。特に私は直感で回答しちゃうタイプなので
 私自身も反省しています。m(__)m
 解決されてほんとによかったです。ではでは、また、v(=∩_∩=)v
（SoulMan）
----
 優しいお言葉ありがとうごさいますm(__)m
 あの・・・先程まで問題なく動いていたのですが・・・
 一息ついて、また使ってみたところ・・？？？
 漢字と英字で追加したものは、一度しかI列に単価表示できなくなってしまいまし
 た・・・
 例えばB3セルで漢字や英字のものの追加を行えば I3に単価が表示されます、
 B5セルから、さっき(B3で)追加されたものをリストから選択しても
 単価が表示されない現象です
 原因がわからず・・(T_T)
 SoulManさんがこのプログラムを使ったら、このような現象は起きないですか？
 先程、報告した時は問題なかったと思うのですが・・・
 ずうずうしくて申し訳ありませんが・・・ためして頂けませんでしょうか・・・
 (なっち)
----
 ありゃ、、確認しました。
 これは、イベントを無効にしているからだと思います。
 For　Eachの最後でふりがなをセットするコードを追加しましたので
 今度こそOKでしょう？？(^^;
 >このような現象は起きないですか？
 すみません。全然試してません。m(__)m
 これで、解決したらMySampleBookに追加しようかな？？
追伸！
あっ、ふりがなは表示されますが、最初に入力した「名前」とは
関係なくなってしまいますね(^^;これは、、いいのかな？？
（SoulMan）
----
 失礼！長くなってしまったけど、、ファイナルアンサーとなります様に・・・
あぁ〜〜めん
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim MyRow As Long
Dim 単価 As Variant, 名前 As Variant
Dim MyData As String, MyPho As String
Dim x As Variant, MyName As Name
Dim MyFlag As Boolean
'実行範囲を制限します。
If Intersect(Target, Range("A1:E10")) Is Nothing Then Exit Sub
'イベントを無効にします。
Application.EnableEvents = False
    With Worksheets("Sheet2")
        'For　Each　でTargetをループします。
        For Each r In Target
            'rが空白じゃなかったら
            If r.Value <> "" Then
                '変数MyDataに代入します。
                MyData = r.Value
                'Findで検索します。
                Set c = .Cells.Find(r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
                    'Findで検索して無かったら
                    If c Is Nothing Then
                        'MsgBoxを表示してYesだったら処理をします。
                        If vbYes = MsgBox(MyData & "　をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                            名前 = Application.InputBox("名前を入力してください。", Type:=2)
                            '名前が入力されたら
                                If TypeName(名前) <> "Boolean" And 名前 <> "" Then
                                    'その名前が定義されているか調べます。
                                    For Each MyName In ThisWorkbook.Names
                                        If MyName.Name = 名前 Then MyFlag = True: Exit For
                                    Next
                                    '名前が定義されていたら
                                    If MyFlag Then
                                    'ループの為にフラグを初期化します。
                                    MyFlag = False
                                    'Matchで列を求めます。
                                    x = Application.Match(名前, .Range("A1:IV1"), 0)
                                    '列があったら（エラーじゃなかったら）
                                        If Not IsError(x) Then
                                            'MsgBoxで単価の入力を確認し、Yesだったら要求します。
                                            If vbYes = MsgBox("単価を入力しますか？", vbYesNo) Then
                                                '単価を要求します。
                                                単価 = Application.InputBox("単価を入力してください。", Type:=1)
                                            End If '単価MsgBox
                                                '単価の入力がキャンセル以外だったら
                                                If TypeName(単価) <> "Boolean" Then
                                                    MyRow = .Cells(65536, x).End(xlUp).Row
                                                    .Cells(MyRow + 1, x).Value = r.Value
                                                    .Cells(MyRow + 1, x + 1).Value = 単価
                                                    '追加された範囲に「名前」入力時に入力された名前を定義します。
                                                    .Range(.Cells(1, x), .Cells(MyRow + 1, x)).Name = 名前
                                                    'このままでは入力規則が設定出来ないので一旦r.Valueに名前を代入します。
                                                    r.Value = 名前
                                                    '選択された範囲の入力規則を一旦消去して
                                                    '"=INDIRECT（" & r.Address(0, 0) & ")"を入力します。
                                                    With r.Validation
                                                        .Delete
                                                        .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & r.Address(0, 0) & ")"
                                                        .ShowError = False
                                                    End With
                                                    '.ShowError = Falseでエラーをトラップしたのでr.ValueにMyDataを代入します。
                                                    r.Value = MyData
                                                    'ふりがなに名前を代入します。
                                                    r.Characters.PhoneticCharacters = 名前
                                                End If '単価
                                        Else
                                            MsgBox 名前 & "　は、ありません"
                                        End If 'ｘ
                                    Else
                                        MsgBox 名前 & "　は定義されていません。"
                                    End If 'MyFlag
                                End If '名前
                        End If 'MsgBox
                    Else
                        'ヒットした列の一行目の名前をMyPhoに代入します。
                        MyPho = .Cells(1, c.Column).Value
                        'ふりがなにMyPhoを代入します。
                        r.Characters.PhoneticCharacters = MyPho
                    End If 'Find
            End If '空白の判定
        Next r
    End With
'イベントを有効にします。
Application.EnableEvents = True
End Sub
ちょっと訂正！
でも、これだといつも同じふりがなになるけど？？？
また、結果を教えてください。
（SoulMan）
----
 衝突を繰り返していました・・・
 完璧です！！！ありがとうございますm(__)mm(__)mm(__)mm(__)mm(__)mm(__)m
 >でも、これだといつも同じふりがなになるけど？？？
 あの・・もっと前に報告すべきだったのでしょうか・・・
 ふりがなを入力する時、「あめ」を「あめ」と入力すると、あめ は定義されてません
 とメッセージが出るので、ふりがなは「あ」しか入力していなかったんです。
 このように使うのだと思っていたのですが、、、
 もしかすると違っていたのでしょうか・・・
 リスト一覧シートのあ列に追加するので、「あ」だと思いまして・・・
 そうではなく、最初に私が作ったリスト一覧シートの名前の定義がおかしいのか
 な？？？
 あっ、そうかもしれないですよね・・・
 もうちょっと調べてみます。頭を冷やしてから・・・
 改めて報告したいと思います。ので明日になるかもしれません
 作って頂いたプログラムは完璧です。ありがとうございますm(__)m
 (なっち)

----
 SoulManさん、こんにちは。
 昨夜は、十分なお礼の言葉も書かず・・・失礼致しましたm(__)m
 素敵なプログラムを作成して頂き、本当にありがとうございますm(__)m
 改めて、感謝致しておりますm(__)m
 >改めて報告したいと思います。ので明日になるかもしれません
 いろいろ考えたのですが・・・
 始めにシート2に作成していたリスト一覧は
 
  　　　B　    　C      D    　 E　　　　     　 CL     CM　　　
 　1　あ　   単価列   い　　 単価列　・・・→  わ　  単価列
 　2　あ1　　 100　　 い1     150　　　　　　  わ1　　200
　 3　あ2　　 110　　 い2　　 500　　　　　　  わ2　　300
　  
  30　あ29　　500 　

 このようなレイアウトで、挿入→名前→定義したのではなく、B1からCM30範囲を選択して
 挿入→名前→作成→上端行にチェックをして使っていたのですが・・・
 単価列はVLOOKUP関数でシート2を参照している為必要ないので、挿入→名前→定義
 で見て、後から単価列を削除していました。
 SoulManさんは、挿入→名前→定義を使っていたのですよね？
 >でも、これだといつも同じふりがなになるけど？？？
 この疑問はその為でしょうか・・・？
 ・・・なんだか、わけのわからない事を書いてしまってるような・・
 
 プログラムによる追加の仕方も、
 ふりがなを入力する時、「あめ」を「あめ」と入力すると、あめ は定義されてません
 とメッセージが出るので、ふりがなは「あ」しか入力していなかったんです。
 SoulManさんは、「あめ」のふりがなを「あめ」と入力していたのですか？
 この辺が気になってしまいました・・・
 後から面倒な疑問をぶつけてしまい、申し訳ありません。
 もし、お時間がありましたら教えてください。
 あっ！それと参考までに一つ・・・
 もしリスト一覧シート(名前と単価が追加されていくシートです)を別のBookに作成
 した場合、素敵なこのプログラムは大幅に変更しなくてはならないのでしょうか・・？
 (なっち)
----
 おはようございます。
 ふりがなの活用は私が勘違いしていた様です。
 あまり気にしないでください。
 >もしリスト一覧シート(名前と単価が追加されていくシートです)を別のBookに作成
 一応、作ってみましたのでお試しください。
 Book2を対象にし、開いているものとしています。
 それから、↓も参考になると思いますのでよかったら参考にしてください。
[[20050510144918]]『リストについて』（瑪瑙） 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim MyRow As Long
Dim 単価 As Variant, 名前 As Variant
Dim MyData As String, MyPho As String
Dim x As Variant, MyName As Name
Dim Wb As Workbook, MyList As String
Dim MyFlag As Boolean
'対象Bookが開いていたらWbに取得します。
For Each Wb In Workbooks
    If Wb.Name = "Book2.xls" Then
        MyFlag = True
        Set Wb = Wb
        Exit For
    End If
Next
'取得出来なかったら中止します。
If MyFlag = False Then Exit Sub
'MyFlagを初期化します。
MyFlag = False
'実行範囲を制限します。
If Intersect(Target, Range("A1:E10")) Is Nothing Then Exit Sub
'イベントを無効にします。
Application.EnableEvents = False
    'Wbも含めて指定します。
    With Wb.Sheets("Sheet2")
        'For　Each　でTargetをループします。
        For Each r In Target
            'rが空白じゃなかったら
            If r.Value <> "" Then
                '変数MyDataに代入します。
                MyData = r.Value
                'Findで検索します。
                Set c = .Cells.Find(r.Value, , xlValues, xlWhole, xlByColumns, xlPrevious, True)
                    'Findで検索して無かったら
                    If c Is Nothing Then
                        'MsgBoxを表示してYesだったら処理をします。
                        If vbYes = MsgBox(MyData & "　をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                            名前 = Application.InputBox("名前を入力してください。", Type:=2)
                            '名前が入力されたら
                                If TypeName(名前) <> "Boolean" And 名前 <> "" Then
                                    'その名前が定義されているか調べます。
                                    For Each MyName In ThisWorkbook.Names
                                        If MyName.Name = 名前 Then MyFlag = True: Exit For
                                    Next
                                    '名前が定義されていたら
                                    If MyFlag Then
                                    'ループの為にフラグを初期化します。
                                    MyFlag = False
                                    'Matchで列を求めます。
                                    x = Application.Match(名前, .Range("A1:IV1"), 0)
                                    '列があったら（エラーじゃなかったら）
                                        If Not IsError(x) Then
                                            'MsgBoxで単価の入力を確認し、Yesだったら要求します。
                                            If vbYes = MsgBox("単価を入力しますか？", vbYesNo) Then
                                                '単価を要求します。
                                                単価 = Application.InputBox("単価を入力してください。", Type:=1)
                                            End If '単価MsgBox
                                            '単価の入力がキャンセル以外だったら
                                            If TypeName(単価) <> "Boolean" Then
                                                MyRow = .Cells(65536, x).End(xlUp).Row
                                                .Cells(MyRow + 1, x).Value = r.Value
                                                .Cells(MyRow + 1, x + 1).Value = 単価
                                                '追加された範囲に「名前」入力時に入力された名前を定義します。
                                                .Range(.Cells(1, x), .Cells(MyRow + 1, x)).Name = 名前
                                                'このままでは参照出来ないので一旦MyListにアドレスを取得します。
                                                MyList = .Range(.Cells(1, x), .Cells(MyRow + 1, x)).Name
                                                '先頭の「=」が余分なのでRight関数で取り除きます。
                                                MyList = Right(MyList, Len(MyList) - 1)
                                                'このBookに名前を定義します。
                                                ThisWorkbook.Names.Add Name:=名前, RefersTo:="=[" & Wb.Name & "]" & MyList
                                                'このままでは入力規則が設定出来ないので一旦r.Valueに名前を代入します。
                                                r.Value = 名前
                                                '選択された範囲の入力規則を一旦消去して
                                                '"=INDIRECT（" & r.Address(0, 0) & ")"を入力します。
                                                With r.Validation
                                                    .Delete
                                                    .Add Type:=xlValidateList, Formula1:="=INDIRECT（" & r.Address(0, 0) & ")"
                                                    .ShowError = False
                                                End With
                                                '.ShowError = Falseでエラーをトラップしたのでr.ValueにMyDataを代入します。
                                                r.Value = MyData
                                                'ふりがなに名前を代入します。
                                                r.Characters.PhoneticCharacters = 名前
                                            End If '単価
                                        Else
                                            MsgBox 名前 & "　は、ありません"
                                        End If 'ｘ
                                    Else
                                        MsgBox 名前 & "　は定義されていません。"
                                    End If 'MyFlag
                                End If '名前
                        End If 'MsgBox
                    Else
                        'ヒットした列の一行目の名前をMyPhoに代入します。
                        MyPho = .Cells(1, c.Column).Value
                        'ふりがなにMyPhoを代入します。
                        r.Characters.PhoneticCharacters = MyPho
                    End If 'Find
            End If '空白の判定
        Next r
    End With
'イベントを有効にします。
Application.EnableEvents = True
Set Wb = Nothing
End Sub
（SoulMan）
----
 おそくなりました！
 こんにちは！SoulManさん、またまた本当にありがとうございます！！！m(__)m
 別Bookの場合・・・まで対応して下さって・・なんとお礼を申し上げたら良いか・・
 ありがとうございますm(__)m
 よく考えたら、こちらの方が、より、さらに実用的ですね。
 このプログラムをぜひ使用したいと思いまして、別Bookにリストを作成し、入力規則
 や単価の表示を別Bookのリストから使用できるように設定し直しました。
 そこで、、、
 もう一つ、、(また一つ？になってしまいますが・・)
 >Book2を対象にし、開いているものとしています
 プログラムを入れたのがBook1とし、リスト一覧があるのをBook2にしているのですが
 Book1を開くとBook2も同時に開いたほうが良いのだと思い、過去ログを検索した結果
 ぴったりののを見つけました。
 『自動的にファイルを開く』（MOMOKA☆） 
 これなのですが、、、試してみたら？？？うまくいきませんでした(ToT)
 標準モジュールに
 Sub Auto_Open()
 Workbooks.Open Filename:="Book2"
 End Sub
 と書いてみましたが・・・
 実行時エラー'1004': 
 'Book2.xls'が見つかりません。ファイル名及びファイルの保存場所が
 正しいかどうか確認して下さい。
 となってしまいます。
 まだ他を調べている途中ですが、もしお時間がありましたら
 どのようにすれば良いか教えて下さいm(__)m
 [[20050510144918]]『リストについて』（瑪瑙） 
 こちらも勉強させて頂きます。　
 (なっち)
----
 こちらですね
[[20040115102015]]『自動的にファイルを開く』（MOMOKA☆）
一応、作ってみました。
メニューバーのファイルの隣のExcelのマークを右クリック→コードを表示させて
そこに貼り付けます。 
Option Explicit
Private Sub Workbook_Open()
Dim MyPath As String
Dim MyBook As String
Dim Wb As Workbook
Dim MyFlag As Boolean
MyPath = ThisWorkbook.Path
MyBook = "Book2" & ".xls"
If Dir(MyPath & "\" & MyBook) = "" Then
    MsgBox MyPath & "\" & MyBook & "　はありません。"
    Exit Sub
End If
For Each Wb In Workbooks
    If Wb.Name = MyBook Then MyFlag = True: Exit For
Next
If MyFlag = False Then
    Application.ScreenUpdating = False
        Workbooks.Open Filename:=MyPath & "\" & MyBook
        ThisWorkbook.Activate
    Application.ScreenUpdating = True
    MsgBox "準備OKです"
Else
    MsgBox MyPath & "\" & MyBook & " は既に開いています。"
End If
End Sub
（SoulMan）
 ----
 遅くなりました。SoulManさん、ありがとうございますm(__)m
 これで完璧です！！！
 過去ログで検索して見かけた時は、これなら私にもできるかも・・って
 思ったんですけど・・・(あっ、Bookを開く為のコードです)
 難しいですね・・・記述が足りなかった、ということでしょうか・・。
 
 お忙しい中、貴重な時間を使って下さり、素敵なプログラムまで作成して
 頂き、本当にありがとうございましたm(__)m
 ここから成長できるように頑張りたいと思います（*^_^*）
 (なっち)