| |
下記のような住所データを
都道府県 → 市町村名 → 名前 と絞り込んでいくとすると
フォーム上にリストボックスが３個
リストボックス１ = 都道府県
リストボックス２ = 市町村名
リストボックス３ = 名前 として。
一応フィルタしっぱなしと後片付けするもの２つ。
内容はほとんど同じです。たぶん。
（３ヶ月ぐらい前にここの載せようとして、書いたんだけど覚えてません。）
Sheet1のデータ
Ａ Ｂ Ｃ Ｄ Ｅ
No, 氏名 県 市町村 番地 ← ここ１行目。
1 谷 亮子 東京都 渋谷区 1549
2 北島康介 愛知県 名古屋市 1276
3 釜飯豊 愛知県 名古屋市 1277
4 どんぐりコロ 愛知県 春日井市 5495
5 ガイアボッタ 千葉県 鴨川市 1586
6 栗原 恵 長野県 松本市 156987
7 大山加奈 愛知県 春日井市 5496
8 青木とめ 秋田県 秋田市 145000
9 木村舞 長野県 松本市 156
10 観月ありさ 東京都 千代田区 1567
11 阿部美里 長野県 諏訪市 123
12 漫画太郎 東京都 中央区 22
13 のびた 東京都 中央区 23
14 改造ドパ 東京都 墨田区 999
15 伊藤ため 秋田県 秋田市 788
16 ケイン小杉 長野県 八千穂 555
17 もたいまさこ 長野県 八千穂 322
18 猫が好き 長野県 八千穂 89
19 敬老の日 東京都 品川区 124
20 ウォーターボーイズ 秋田県 面倒市 47
21 横山めぐみ 大阪府 中央区 88888
22 ミルマスカラス 秋田県 八郎潟 7777
23 Ｑ太郎 東京都 中央区 24
24 遠隔ピーズ 東京都 墨田区 998
25 インディオ 長野県 松川村 3345
１、シート上のフィルタを戻す。
これ使えないので、消しました。
すみません。
２、シート上フィルタしたまま
標準モジュール
Public CE As Long 'これ忘れないでね。
Sub 絞込み2()
Dim Ctl As Range, LbTb() As String, Cnt As Long
ActiveSheet.AutoFilterMode = False
CE = ActiveSheet.Range("C65536").End(xlUp).Row
ActiveSheet.Range("C1:C" & CE).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
CAE = Range("C2").End(xlDown).Row
Set Ctl = ActiveSheet.Range("C2:C" & CAE).SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
ActiveSheet.ShowAllData
DoEvents
Cnt = 0
For Each ccc In Ctl
Cnt = Cnt + 1
ReDim Preserve LbTb(1 To Cnt)
LbTb(Cnt) = ccc
Next
UserForm2.ListBox1.List = LbTb
Set Ctl = Nothing
Erase LbTb
Application.ScreenUpdating = True
UserForm2.Show
End Sub
フォームモジュール
Private Sub ListBox1_Click()
Dim CT2 As Range, Cel As Range, LB2tb() As String
Application.ScreenUpdating = False
ListBox2.Clear
ListBox3.Clear
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
LtW = ListBox1.List(ListBox1.ListIndex)
Range("A1").AutoFilter field:=3, Criteria1:=LtW
Set CT2 = Range("D2:D" & CE).SpecialCells(xlCellTypeVisible)
ListBox2.Clear
Cnt = 0
For Each Cel In CT2
On Error Resume Next
mt = Application.Match(Cel, ListBox2.List, 0)
If IsError(mt) Or mt = Empty Then
Cnt = Cnt + 1
ReDim Preserve LB2tb(1 To Cnt)
LB2tb(Cnt) = Cel
End If
ListBox2.List = LB2tb
Err.Clear
On Error GoTo 0
Next
Set CT2 = Nothing
Erase LB2tb
Application.ScreenUpdating = True
End Sub
Private Sub ListBox2_Click()
Dim CT3 As Range, Cel As Range, LB3tb() As String, mt As Variant
Application.ScreenUpdating = False
ListBox3.Clear
LtW = ListBox2.List(ListBox2.ListIndex)
Range("A1").AutoFilter field:=4, Criteria1:=LtW
Set CT3 = Range("B2:B" & CE).SpecialCells(xlCellTypeVisible)
ListBox3.Clear
Cnt = 0
For Each Cel In CT3
On Error Resume Next
mt = Application.Match(Cel, ListBox3.List, 0)
If IsError(mt) Or mt = Empty Then
Cnt = Cnt + 1
ReDim Preserve LB3tb(1 To Cnt)
LB3tb(Cnt) = Cel
End If
ListBox3.List = LB3tb
Err.Clear
On Error GoTo 0
Next
Set CT3 = Nothing
Erase LB3tb
Application.ScreenUpdating = True
End Sub
Private Sub ListBox3_Click()
MsgBox ListBox3.List(ListBox3.ListIndex)
End Sub
Private Sub CommandButton1_Click()
ActiveSheet.AutoFilterMode = False
Unload Me
End Sub
|
|
Jaka
- 04/12/6(月) 9:24 -
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
≪
