[[20160424040943]]　『一覧シートのフィルタ内容を別のシートで表示（入』（yk）　ページの最後に飛ぶ

『一覧シートのフィルタ内容を別のシートで表示（入力規則？）』（yk）

はじめまして。お世話になります。

フィルタをしない状態で「一覧シート」

●対象　　　　●第一カテゴリ　●第二カテゴリ　●ID
レディース　　スカート　　　　ミニスカート　　　XAL05
レディース　　スカート　　　　ロングスカート　　ACC02
レディース　　コート　　　　　　　　　　　　　　JKA11　　
レディース　　靴下　　　　　　　　　　　　　　　FJIDF
メンズ　　　　パンツ　　　　　ハーフパンツ　　　IFEKOD
メンズ　　　　パンツ　　　　　長ズボン　　　　　ASDF
メンズ　　　　コート　　　　　　　　　　　　　　IDJD1　　　　
メンズ　　　　靴下　　　　　　　　　　　　　　　RAIE4
子供　　　　　コート
子供　　　　　（略）

↓

などの下に向かって 400行くらいの一覧があり、
左から　フィルタ機能で選んでいくと重複がないリストで選べて
レディース・スカート・ロングスカートでACC02など最終的に一行だけ表示されます。
（最終目的は、IDを調べる）

これを別の「入力シート」E列～H列などの４列の中で全て（１行ではなく複数行に）　、
フィルタの内容だけが出る状態で取り入れるような方法はありますでしょうか？
（入力シートE列で「メンズ」を選んだらF列～のリスト（フィルタ）でパンツ等メンズの内容）

今は、「入力シート」から「一覧シート」に移動してフィルタで選んで出たIDを「入力シート」に戻って、該当箇所にコピペしています。

シートを移動せずに直接「入力シート」内から選べたらと思ったのですが・・・

調べている中で、並び方が違うリスト（上部に選択内容、以下にその表示内容の入力規則用のリスト）からできそうなのは見ました。
（○○部署　の選択で　○○さん・▽▽さん　など一段階）
今の400行の一覧状態からは、難しいでしょうか？

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

アイデアだけ。

１．一覧シートで普通に順にオートフィルタで絞り込む
２．一覧シートで絞り込まれたIDを右クリックする
３．その右クリックされた行のデータが入力シートの最終行にコピーされる

コードは、一覧シートのBeforRightClickイベントにほんの数行から十数行
で済むと思われる。

（とおりすがり） 2016/04/24(日) 10:10

入力シートからの操作にこだわるなら、

 　
[[20160415174139]]『入力規制で選んだものによって入力規制の内容を変』（さるさ）
で紹介した
[[20130417213938]]『ドロップダウン3連続』（xxxx） 
のCodさんのマクロが使えそうです。

（マナ） 2016/04/24(日) 11:51

とおりすがりさんの案をダブルクリックイベントにしました。

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Target.Column <> 4 Then Exit Sub
    Sheets("入力").Range("E" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = _
        Target.EntireRow.Range("A1").Resize(, 4).Value

    Cancel = True

 End Sub

（マナ） 2016/04/24(日) 19:59

Codさんのマクロを使用した場合は、こんな感じです。

 ↑のダブルクリックイベントのコードは消してから試して下さい。

 １）下記にコードを標準モジュールとシートモジュールにコピペ
 ２）最初に「準備」マクロを実行　（Alt+F8から選択）
 ３）入力シートE2の入力規則リストから選択
 ４）同様にF2、G2で選択
 ５）H2にIDが表示される

 ' --------------------------/*Module1 など標準モジュールに貼り付け

 Public Dic As Object

 Sub 準備()         '★ブックを開いた時やリスト更新時に実行
    Dim r As Range
    Dim W1, Wx, i As Long

    Set r = Sheets("入力").Range("E2:E10")                  '★入力規則の設定範囲
    W1 = Sheets("一覧").Range("A1").CurrentRegion.Value     '★元データリスト

    Set Dic = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(W1)
        If IsEmpty(W1(i, 3)) Then W1(i, 3) = "_"
        Wx = Array(W1(i, 1), W1(i, 2), W1(i, 3), W1(i, 4))

        If Not Dic.exists(Wx(0)) Then
            Set Dic(Wx(0)) = CreateObject("Scripting.Dictionary")
        End If
        If Not Dic(Wx(0)).exists(Wx(1)) Then
            Set Dic(Wx(0))(Wx(1)) = CreateObject("Scripting.Dictionary")
        End If
        Dic(Wx(0))(Wx(1))(Wx(2)) = Wx(3)
    Next

    Vlist r, Dic.keys

    Application.EnableEvents = True

 End Sub

 Function Vlist(P1 As Range, P2)      '入力規則の作成

    With P1.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=Join(P2, ",")
    End With

 End Function
　
 　
 　
 　
 　
 ' --------------------------/*入力シートのシート・モジュールに貼り付け

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cc As Range, c As Range

    Application.EnableEvents = False

    Set cc = Target.Columns(1).Cells

    Select Case cc.Column
        Case 5
            cc.Offset(, 1).Resize(, 3).ClearContents
            cc.Offset(, 1).Resize(, 2).Validation.Delete
            For Each c In cc
                If c.Value <> "" Then
                    Vlist c.Offset(, 1), Dic(c.Value).keys
                End If
            Next

        Case 6
            cc.Offset(, 1).Resize(, 2).ClearContents
            cc.Offset(, 1).Validation.Delete
            For Each c In cc
                If c.Value <> "" Then
                    If c.Offset(, -1).Value = "" Then
                        c.ClearContents
                    Else
                        With Dic(c.Offset(, -1).Value)(c.Value)
                            If .Count > 1 Then
                                Vlist c.Offset(, 1), .keys
                            Else
                                c.Offset(, 2).Value = .Item("_")
                            End If
                        End With
                    End If
                End If
            Next

        Case 7
            cc.Offset(, 1).ClearContents
            For Each c In cc
                If c.Value <> "" Then
                    If c.Offset(, -1).Value = "" Then
                        c.ClearContents
                    Else
                        c.Offset(, 1).Value = _
                            Dic(c.Offset(, -2).Value)(c.Offset(, -1).Value)(c.Value)
                    End If
                End If
            Next
    End Select

    Application.EnableEvents = True

 End Sub

（マナ） 2016/04/24(日) 21:12

アイデアやコードをくださり、ありがとうございます！
教えていただきました「標準モジュールとシートモジュール」のでまさに希望していた動作になりすごく感動しました！

すごいです。並べ替えて入力規則なども試してましたが、元の一覧からできてスッキリしました。
本当に感謝しております。ありがとうございました。

以下はもしまた回答いただけたらで良いのですが、

「一覧」シートはA～Dの４列で変わることはないと思うのですが、
「入力」シートは項目が多く作成途中の例だったため、実際はもっと後ろの列だったり、今後列が変わる可能性もあるシートで、

「入力」シートのフィルタ表示したい列をEから別の列に変えた場合は、エラーが出てしまいました。
VBAはほとんど分からないので申し訳ないのですが

＞Set r = Sheets("入力").Range("E2:E10") '★入力規則の設定範囲

のE2:E10　を、フィルタの初めにする列のかと思ったのですが、「F2:F10」などに変えると
それだけだとうまく動きませんでした。
修正箇所が多いようでしたら、E列のままできるようにします。

助かりました。ありがとうございました。
（yk） 2016/04/25(月) 15:36

修正版です。F2:F20の部分を入れ替えて試してみてください。

 マクロで設定した入力規則が残ってしまっているかもしれませんので、
 最初だけ、手動で、入力規則を削除しておいて下さい。
 次回からは、「準備」を実行すると自動で不要な入力規則を削除します。

 　
''---------------------------------------------/*Module1 など標準モジュールに貼り付け

 Public Dic As Object

 Sub 準備()         'リスト更新時に実行
    Dim r As Range
    Dim W1, Wx, i As Long

    On Error Resume Next
    Range("エクセルの学校").Resize(, 3).Validation.Delete
    On Error GoTo 0

    Set r = Sheets("入力").Range("F2:F20")                  '★入力規則を設定する範囲
    W1 = Sheets("一覧").Range("A1").CurrentRegion.Value     '★元データリスト

    r.Name = "エクセルの学校"

    Set Dic = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(W1)
        If IsEmpty(W1(i, 3)) Then W1(i, 3) = "_"
        Wx = Array(W1(i, 1), W1(i, 2), W1(i, 3), W1(i, 4))

        If Not Dic.exists(Wx(0)) Then
            Set Dic(Wx(0)) = CreateObject("Scripting.Dictionary")
        End If
        If Not Dic(Wx(0)).exists(Wx(1)) Then
            Set Dic(Wx(0))(Wx(1)) = CreateObject("Scripting.Dictionary")
        End If
        Dic(Wx(0))(Wx(1))(Wx(2)) = Wx(3)
    Next

    Vlist r, Dic.keys

    Application.EnableEvents = True

 End Sub

 Function Vlist(P1 As Range, P2)      '入力規則の作成

    With P1.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=Join(P2, ",")
    End With

 End Function
 　
 　
 　
 　
' ---------------------------------------------/*入力シートのシート・モジュールに貼り付け

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cc As Range, c As Range
    Dim col As Long

    Application.EnableEvents = False

    col = Range("エクセルの学校").Column
    Set cc = Target.Columns(1).Cells

    Select Case cc.Column
        Case col
            cc.Offset(, 1).Resize(, 3).ClearContents
            cc.Offset(, 1).Resize(, 2).Validation.Delete
            For Each c In cc
                If c.Value <> "" Then
                    Vlist c.Offset(, 1), Dic(c.Value).keys
                End If
            Next

        Case col + 1
            cc.Offset(, 1).Resize(, 2).ClearContents
            cc.Offset(, 1).Validation.Delete
            For Each c In cc
                If c.Value <> "" Then
                    If c.Offset(, -1).Value = "" Then
                        c.ClearContents
                    Else
                        With Dic(c.Offset(, -1).Value)(c.Value)
                            If .Count > 1 Then
                                Vlist c.Offset(, 1), .keys
                            Else
                                c.Offset(, 2).Value = .Item("_")
                            End If
                        End With
                    End If
                End If
            Next

        Case col + 2
            cc.Offset(, 1).ClearContents
            For Each c In cc
                If c.Value <> "" Then
                    If c.Offset(, -1).Value = "" Then
                        c.ClearContents
                    Else
                        c.Offset(, 1).Value = _
                            Dic(c.Offset(, -2).Value)(c.Offset(, -1).Value)(c.Value)
                    End If
                End If
            Next
    End Select

    Application.EnableEvents = True

 End Sub

（マナ） 2016/04/25(月) 21:57

マナ様

修正版まで用意して頂きまして本当にありがとうございます。

修正版で試して列を移動しても問題なく動作しました！！完璧素晴らしいです！
これで入力がスムーズにできます☆（嬉）

VBAへの興味が増しました。私も少しづつ覚えて書けるようになりたいです。
本当に感謝いたします。ありがとうございました。

（yk） 2016/04/25(月) 23:58

コメント返信：

[ 一覧(最新更新順) ]

[[20160424040943]] 『一覧シートのフィルタ内容を別のシートで表示（入』（yk） ページの最後に飛ぶ

[[20160424040943]]　『一覧シートのフィルタ内容を別のシートで表示（入』（yk）　ページの最後に飛ぶ