[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一覧シートのフィルタ内容を別のシートで表示(入力規則?)』(yk)
はじめまして。お世話になります。
フィルタをしない状態で「一覧シート」
●対象 ●第一カテゴリ ●第二カテゴリ ●ID
レディース スカート ミニスカート XAL05
レディース スカート ロングスカート ACC02
レディース コート JKA11
レディース 靴下 FJIDF
メンズ パンツ ハーフパンツ IFEKOD
メンズ パンツ 長ズボン ASDF
メンズ コート IDJD1
メンズ 靴下 RAIE4
子供 コート
子供 (略)
↓
などの下に向かって 400行くらい の一覧があり、
左から フィルタ 機能で選んでいくと重複がないリストで選べて
レディース・スカート・ロングスカートでACC02など最終的に一行だけ表示されます。
(最終目的は、IDを調べる)
これを別の「入力シート」E列 〜H列などの4列の中で全て(1行ではなく複数行に) 、
フィルタの内容だけが出る状態で取り入れるような方法はありますでしょうか?
(入力シートE列で「メンズ」を選んだらF列〜のリスト(フィルタ)でパンツ等メンズの内容)
今は、「入力シート」から「一覧シート」に移動してフィルタで選んで出たIDを「入力シート」に戻って、該当箇所にコピペしています。
シートを移動せずに直接「入力シート」内から選べたらと思ったのですが・・・
調べている中で、並び方が違うリスト(上部に選択内容、以下にその表示内容の入力規則用のリスト)からできそうなのは見ました。
(○○部署 の選択で ○○さん・▽▽さん など一段階)
今の400行の一覧状態からは、難しいでしょうか?
< 使用 Excel:Excel2013、使用 OS:Windows10 >
1.一覧シートで普通に順にオートフィルタで絞り込む
2.一覧シートで絞り込まれたIDを右クリックする
3.その右クリックされた行のデータが入力シートの最終行にコピーされる
コードは、一覧シートの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
↑のダブルクリックイベントのコードは消してから試して下さい。
1)下記にコードを標準モジュールとシートモジュールにコピペ 2)最初に「準備」マクロを実行 (Alt+F8から選択) 3)入力シートE2の入力規則リストから選択 4)同様にF2、G2で選択 5)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の4列で変わることはないと思うのですが、
「入力」シートは項目が多く作成途中の例だったため、実際はもっと後ろの列だったり、今後列が変わる可能性もあるシートで、
「入力」シートのフィルタ表示したい列をEから別の列に変えた場合は、エラーが出てしまいました。
VBAはほとんど分からないので申し訳ないのですが
>Set r = Sheets("入力").Range("E2:E10") '★入力規則の設定範囲
のE2:E10 を、フィルタの初めにする列のかと思ったのですが、「F2:F10」などに変えると
それだけだとうまく動きませんでした。
修正箇所が多いようでしたら、E列のままできるようにします。
助かりました。ありがとうございました。
(yk) 2016/04/25(月) 15:36
マクロで設定した入力規則が残ってしまっているかもしれませんので、 最初だけ、手動で、入力規則を削除しておいて下さい。 次回からは、「準備」を実行すると自動で不要な入力規則を削除します。
''---------------------------------------------/*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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.