[[20050510144918]]　『リストについて』（瑪瑙）　ページの最後に飛ぶ

『リストについて』（瑪瑙）

こんにちは、お邪魔します。

 早速ですが[[20050425224445]]に書かれているリスト追加について教えていただければ
 嬉しく思います。似たようなことが“なっち”さんの所でも質問されていたのですが、
 何分VBAは初心者で応用が難しいので質問させていただきます。転載させていただきま
 すが、

 Option Explicit

 Private Sub Worksheet_Change(ByVal Target As Range)
 Dim c As Range
 Dim LastR As Long
 If Target.Address <> "$D$5" Then Exit Sub

 ↑このTargetは一つのセルが選択されていますが、複数のセルを選択する場合どう記述
 したら良いのでしょうか。

Excelのverは2002で、OSはXP(HE)です。忙しいと存じますがぜひお願いします。

 こんにちは！
 >複数のセルを選択する場合どう記述したら良いのでしょうか。
 それは、なっちさんも質問されていますが
 >入力規則のリストを下方向にコピーしてみた のですが)
 と、同じことですよね？
 ということで
 >これは変数を一つ用意して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, ふりがな As String
Dim x As Variant
If Intersect(Target, Range("A1:A100")) Is Nothing Then Exit Sub
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
                            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
    Next r
    End With
Application.EnableEvents = True
End Sub
（SoulMan）

 SoulManさん、ありがとうございます。私も読んだのですが、日本語の意味を理解し損 
 ねていました。「入力規則のリストを下方向にコピー」ってそういうことだったのです
 ね。日本語難しい。ただ、私は、“MyStr = InputBox("単価を入力してください。")”
 単価はいいので、これだけ削除すればよろしいですか？（瑪瑙）

 >これだけ削除すればよろしいですか？
 - - - - - -
 MyStr = InputBox("単価を入力してください。")
 If MyStr <> "" Then

 End If
 - - - - - -
 これがセットなのでこの部分を削除されたらいいでしょう。
 #単価に「MyStr」って変な変数の名前ですね(^^; 
 上のコードは修正しておきました。
（SoulMan）

 ありがとうございました。ふりがなも私は使わないので、セットで削除すればいいので
 すね。
 何度も質問して失礼とは思いますが、もう一つ宜しいですか。上の記述ですと全てのセ
 ルが選択されていると思いますが、例えば一列のセルで100行を選択するとどんな記述
 になるのでしょうか。何卒お願いします。（瑪瑙）

 おはようございます。
上のコードで
 >全てのセルが選択されていると思いますが
 となると
 >.Cells.Find(
 この部分だと思いますが、
 >一列のセルで100行を選択する
 となると、色々あるでしょうが
 Range ("A1:A100").Find(
 Range("A1").Resize (100).Find(
 とかでしょうか？？
（SoulMan）

 こんばんわ。試してみましたら、A1:100の範囲だけ“リストに追加しますか？”という
 表示が出なくなってしまいました。(^o^)その逆を自分なりに考えたのですが、脳がつ 
 るつるになりそうです。どうぞ力を貸してください。

 例えば、Sheet1! A1:100の間だけSheet2!$A$1からのリストに追加し、Sheet1! B1:10と
 D1:10の間だけ、Sheet2!$B$1からのリスト２に追加したいという感じです。真実に届き
 そうで届かない、悔しいです。初心な質問かも知れませんが何卒お願いします。

 失礼！
これを先頭に記述してください。
上のコードは修正しています。
If Intersect(Target, Range("A1:A100")) Is Nothing Then Exit Sub
（SoulMan）

 おはようございます。
朝起きてよく読んだらなんか違いますね？？
Sheet1とSheet2を同じ列で対応したいということでしょうか？
ちょっと変更してみましたのでお試しください。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, r As Range
Dim MyRow As Long, x As Long
If Intersect(Target, Range("A1:E10")) Is Nothing Then Exit Sub
Application.EnableEvents = False
With Sheets("Sheet2")
    For Each r In Target
        If r.Value <> "" Then
            x = r.Column
            Set c = .Columns(x).Find(r.Value, , xlValues, xlWhole, xlByColumns, xlNext, True)
            If c Is Nothing Then
                If vbYes = MsgBox("この名前をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                    MyRow = .Cells(65536, x).End(xlUp).Row
                    .Cells(MyRow + 1, x).Value = r.Value
                    .Range(.Cells(2, x), .Cells(MyRow + 1, x)).Name = "リスト" & x
                    With Target.Validation
                        .Delete
                        .Add Type:=xlValidateList, Formula1:="=リスト" & x
                        .ShowError = False
                    End With
                End If
            End If
        End If
    Next r
End With
Application.EnableEvents = True
End Sub
（SoulMan）

 こんにちは。
 >Sheet1とSheet2を同じ列で対応したいということでしょうか？
 そういう意味ではありませんでした。すいません。
 Sheet1のTargetセル選択はこれで大丈夫です、ありがとうございます。簡単に書きます
 と、

       A      B      C      D      …
1     ○○
2
3　　　　　　　　　 △△

10　　□□

 上のような表がSheet1にあります。
 Sheet2にはAのセルにメンバーのグループの名前（例えば15人のメンバー）が定義づけ 
 されています。
 B,C,Dまでそれぞれの名前が4グループまで定義づけされています。

 ここで私が行いたいことが、
 例えばSheet1表のA列のセルにはSheet2のBグループからのメンバーの名前しか使いませ
 んが、Sheet1表のC列のセルにはSheet2のAとBの、二つのグループメンバーからの名前
 が必要なわけです。

 初めは名前は入力されていないのですが、
 Sheet1の表に例えばC4に名前を入れれば、「リストに追加しますか」という表示を出し
 okを押したら、「Sheet2のAとBどちらに追加しますか」と出てリストに追加できるよう
 なイメージをしております。
 もちろんSheet1のA3などに入力した場合は、Sheet2のリストのBグループだけに収まれ
 ば良いので「リストに追加しますか」という表示を出し、okしたらそのまま追加される
 感じです。

 初めからこのように詳しく書けば良かったです。すいませんでした。
 忙しいとは思いますがお願いします。（瑪瑙）

 すみません。今読んでるんですが、最初からわかりません。
 >Sheet2にはAのセルにメンバーのグループの名前（例えば15人のメンバー）が定義づけされています。
 どの様にされているのですか？
 >Aのセルに
 A列？？A1？？？
 >例えば15人のメンバー
 もう少し、具体的に教えてくださいませんか？
 >二つのグループメンバーからの名前が必要なわけです。
 何故？必要なのか私にはわかりません。分からないのは私だけかもしれませんがぁ。。
 すみません。もうちょっとお願いします。m(__)m
追加です。
まず、ご自身がコードを書くとしたらどの様に書かれますか？
ご自身が書くつもりでお願いします。
（SoulMan）

 あらら…。度々すいません。
 >どの様にされているのですか？
 Sheet2に移動して、上のメニューの「挿入」をクリックすると名前という項目が出てき
 ますよね。
　そこで定義をクリックして例えばセル$A$1に若人という名前で定義します。同じく
 $B$1には年長とします。A列には若い人の名前が追加されていき、B列には年長の方の名
 前が追加されていく感じです。

 >例えば15人のメンバー
 これは別に何人だろうとかまいません。よく考えたらあまり必要ないと思いますので、
 記述からはずしていただければと思います。

 >二つのグループメンバーからの名前が必要なわけです。
 これは、当番みたいな感じで、Sheet1の表のある列には若い人、年長の方の両方のグル
 ープの中から一人を選びたいと言った方が判り易いでしょうか。逆にSheet1の表のある
 特定の列には、若い人の中から一人を選出するといった感じです。

 >まず、ご自身がコードを書くとしたらどの様に書かれますか？ご自身が書くつもりで
 お願いします。
 私は素人なので、はっきり言うと自分がやりたいことは高望みで自分の力では書けませ
 ん。初歩的な（例えば、特定のセルを選択する、少しの関数を組み込む）ことしかでき
 ません。
　ただ、SoulManさんの書かれているコードが大体なら何を示しているか分かります。少
 しの書き直しくらいはできますが、一方で法則などを理解していないことの方が多いで
 す。ならやるなと思われるかもしれませんが、やっていただけるなら是非ご助力をお願
 いします。（瑪瑙）

 何から手をつけたらいいのかわからないのでとりあえず、
今のコードではどこが一番都合が悪いですか？
今回の場合は、検索が主ですから、言葉でいうと
どこからどこまでに入力したら、どこからどこまでから探す
となると思うのですがどうでしょうか？
（SoulMan）

 分かりにくいことを書いてしまってすいません。修正されたコードを実行したところ
 リストに追加しますか。というメッセージボックスは出ましたが、Sheet2のリストに追
 加されなくなっていました。同時にSheet1の表の入力したセルの横に矢印が出ません。

 >どこからどこまでに入力したら、どこからどこまでから探す
 となると思うのですがどうでしょうか？
 おっしゃるとおりです。今回の私の目的は、一度入力した名前をまた入力するのが面倒
 だという理由です。
　どこからどこまでにというのは、不具合はないです。どこからどこまでから探すとい
 うことで私がちょっと混乱させてしまいました。これはSheet2のリストということでお
 願いします。（瑪瑙）

 こんな感じでどうでしょうか？
範囲などは適当に応用してください。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim 検索範囲 As Range, 追加するセル As Range
Dim 検索変数 As Range, 検索結果 As Range
Dim リスト名 As String
Dim 対象先シート As Worksheet
Dim 判定フラグ As Boolean
Set 対象先シート = Sheets("Sheet2")
If Intersect(Target, Range("A1:A100,B1:B10,D1:D10")) Is Nothing Then Exit Sub
For Each 検索変数 In Target
If 検索変数.Value <> "" Then
    判定フラグ = False
    Select Case True
        Case 検索変数.Column = 1
            Select Case True
                Case 検索変数.Row > 5 And 検索変数.Row < 100
                    判定フラグ = True
                    With 対象先シート
                        Set 検索範囲 = .Range("A1", .Range("A65536").End(xlUp))
                        Set 追加するセル = .Range("A65536").End(xlUp).Offset(1)
                    End With
                    リスト名 = "リスト1"
            End Select
        Case 検索変数.Column = 2 Or 検索変数.Column = 4
            Select Case True
                Case 検索変数.Row > 2 And 検索変数.Row < 10
                    判定フラグ = True
                    With 対象先シート
                        Set 検索範囲 = .Range("B1", .Range("B65536").End(xlUp)).Resize(, 2)
                        Set 追加するセル = .Range("B65536").End(xlUp).Offset(1)
                    End With
                    リスト名 = "リスト2"
            End Select
    End Select
    If 判定フラグ Then
        Set 検索結果 = 検索範囲.Find(検索変数.Value, , xlValues, xlWhole, xlByColumns, xlNext, True)
        If 検索結果 Is Nothing Then
            If vbYes = MsgBox(検索変数.Value & "　をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                追加するセル.Value = 検索変数.Value
                With 対象先シート
                    .Range(.Cells(2, 追加するセル.Column), .Cells(65536, 追加するセル.Column).End(xlUp)).Name = リスト名
                End With
                With 検索変数.Validation
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=" & リスト名
                    .ShowError = False
                End With
            End If
        End If
    End If
End If
Next 検索変数
Set 対象先シート = Nothing
Set 検索範囲 = Nothing
Set 検索結果 = Nothing
Set 追加するセル = Nothing
End Sub
（SoulMan）

 こんばんわ。お忙しい中ありがとうございます。範囲などを入れてやって見ます。
 結果はまた後ほど報告いたします。（瑪瑙）

 おはようございます。
こちらのなっちさんから別Bookでという要望があったので
[[20050427110557]]『入力規則のリストに追加』（なっち） 
こちらも別Bookヴァージョンを作ってみました。よかったら参考にしてください。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim 検索範囲 As Range, 追加するセル As Range
Dim 検索変数 As Range, 検索結果 As Range
Dim 対象ブック As Workbook, 対象先シート As Worksheet
Dim リスト名 As String, 参照先名前 As String
Dim 判定フラグ As Boolean
For Each 対象ブック In Workbooks
    If 対象ブック.Name = "Book2.xls" Then
        判定フラグ = True
        Set 対象ブック = 対象ブック
        Exit For
    End If
Next
If 判定フラグ = False Then Exit Sub
Set 対象先シート = 対象ブック.Sheets("Sheet2")
If Intersect(Target, Range("A1:A100,B1:B10,D1:D10")) Is Nothing Then Exit Sub
For Each 検索変数 In Target
If 検索変数.Value <> "" Then
    判定フラグ = False
    Select Case True
        Case 検索変数.Column = 1
            Select Case True
                Case 検索変数.Row > 5 And 検索変数.Row < 100
                    判定フラグ = True
                    With 対象先シート
                        Set 検索範囲 = .Range("A1", .Range("A65536").End(xlUp))
                        Set 追加するセル = .Range("A65536").End(xlUp).Offset(1)
                    End With
                    リスト名 = "リスト1"
            End Select
        Case 検索変数.Column = 2 Or 検索変数.Column = 4
            Select Case True
                Case 検索変数.Row > 2 And 検索変数.Row < 10
                    判定フラグ = True
                    With 対象先シート
                        Set 検索範囲 = .Range("B1", .Range("B65536").End(xlUp)).Resize(, 2)
                        Set 追加するセル = .Range("B65536").End(xlUp).Offset(1)
                    End With
                    リスト名 = "リスト2"
            End Select
    End Select
    If 判定フラグ Then
        Set 検索結果 = 検索範囲.Find(検索変数.Value, , xlValues, xlWhole, xlByColumns, xlNext, True)
        If 検索結果 Is Nothing Then
            If vbYes = MsgBox(検索変数.Value & "　をリストに追加しますか？", vbYesNo, "名前の追加の確認") Then
                追加するセル.Value = 検索変数.Value
                With 対象先シート
                    .Range(.Cells(2, 追加するセル.Column), _
                            .Cells(65536, 追加するセル.Column).End(xlUp)).Name = リスト名
                    参照先名前 = .Range(.Cells(2, 追加するセル.Column), _
                            .Cells(65536, 追加するセル.Column).End(xlUp)).Name
                    参照先名前 = Right(参照先名前, Len(参照先名前) - 1)
                  ThisWorkbook.Names.Add Name:=リスト名, RefersTo:="=[" & 対象ブック.Name & "]" & 参照先名前
                End With
                With 検索変数.Validation
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=" & ThisWorkbook.Names(リスト名).Name
                    .ShowError = False
                End With
            End If
        End If
    End If
End If
Next 検索変数
Set 対象ブック = Nothing
Set 対象先シート = Nothing
Set 検索範囲 = Nothing
Set 検索結果 = Nothing
Set 追加するセル = Nothing
End Sub
（SoulMan）

 こんにちは。“別Bookで”とは思いもよりませんでしたが、勉強の為に頑張ってみま 
 す。なっちさんのログも拝見しましたが、判り易く記述されていていいですね。ありが
 とうございます。

コメント返信：

[ 一覧(最新更新順) ]

[[20050510144918]] 『リストについて』（瑪瑙） ページの最後に飛ぶ

[[20050510144918]]　『リストについて』（瑪瑙）　ページの最後に飛ぶ