Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


70752 / 76738 ←次へ | 前へ→

【10488】Re:リストボックスにフィルタ適用後のセル範...
回答  ichinose  - 04/1/28(水) 21:27 -

引用なし
パスワード
   ▼ハットリ さん:
こんばんは。
>リストボックスのRowSourceプロパティに
↑のリストボックスは、ユーザーフォームに配置したものですね?
>シート上のセル範囲を指定して複数列表示させているのですが、
>シート上でオートフィルタを使い表示させた行のみをリストボックスに
>連動して表示させることはできないでしょうか。
フィルタ操作後、瞬時にユーザーフォーム上のリストボックスに
反映させるということですね?
Autofilter_Changeというイベントがあればいいんですが・・・・。

思いついたのは、ワークシート関数を配置してCaluculateイベントを発生してもらう
方法なんですが・・・。

仮にSheet1のセルA1から、以下のデータが入っているものとします。
項目1    項目2    項目3
1    2004/1/28     a
2    2004/1/29     b
3    2004/1/30     c
4    2004/1/31     d
5    2004/2/1     e
6    2004/2/2     f
7    2004/2/3     g
8    2004/2/4     h
9    2004/2/5     I
10    2004/2/6     j
11    2004/2/7     k
12    2004/2/8     l
13    2004/2/9     m
14    2004/2/10     n
15    2004/2/11     o
16    2004/2/12     p
17    2004/2/13     q
18    2004/2/14     r
19    2004/2/15     s
20    2004/2/16     t
21    2004/2/17     u
この3列をフィルタ操作後、リストボックスに反映させることを考えました。
ユーザーフォーム(Userform1)には、リストボックス(Listbox1)のみ配置して下さい
コードは、
標準モジュールに、
'=============================================================
Public rng As Range
Sub main()
  Application.Calculation = xlAutomatic
  UserForm1.Show vbModeless
End Sub
'=============================================================
Function chk_autofilter(wk As Worksheet) As Boolean
'input wk チェックするワークシート
'Out  chk_autofilter true オートフィルター実行中
'           false         実行していない
'ここのチェックは、もっと条件を付けないとまずいかもしれません
  On Error Resume Next
  chk_autofilter = True
  Set fl = wk.AutoFilter.Range
  If Err.Number <> 0 Then
   chk_autofilter = False
   End If
  On Error GoTo 0
End Function

ユーザーフォーム(Userform1)のモジュールに、
'=============================================================
Private Sub UserForm_Initialize()
  With Worksheets("sheet1")
   If chk_autofilter(Worksheets("sheet1")) = True Then
     Selection.AutoFilter
     End If
   Set rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
   End With
  If rng.Row > 1 Then
   Application.EnableEvents = False
   Worksheets("sheet1").Range("z1").Formula = "=subtotal(3," & rng.Address & ")"
'    セルz1に、ワークシート関数を入れておきました。セルの位置はとこでも
'    いいです
   rng.Offset(-1, 0).Resize(rng.Count + 1, 3).AutoFilter
   ListBox1.BoundColumn = 3
   ListBox1.List = rng.Resize(, 3).Value
   Application.EnableEvents = True
   End If
End Sub
'=============================================================
Private Sub UserForm_Terminate()
  If chk_autofilter(Worksheets("sheet1")) = True Then rng.AutoFilter
  Worksheets("sheet1").Range("z1").Value = ""
End Sub


シート(Sheet1)のモジュールに
'=============================================================
Private Sub Worksheet_Calculate()
  Dim f_rng As Range
  Application.EnableEvents = False
  If chk_autofilter(Me) = True Then
   UserForm1.ListBox1.Clear
   Set f_rng = get_rng()
   If Not f_rng Is Nothing Then
     ReDim d_list(1 To f_rng.Count, 1 To 3)
     kdx = 1
     For idx = 1 To f_rng.Areas.Count
      For jdx = 1 To f_rng.Areas(idx).Count
       d_list(kdx, 1) = f_rng.Areas(idx).Cells(jdx).Value
       d_list(kdx, 2) = f_rng.Areas(idx).Cells(jdx, 2).Value
       d_list(kdx, 3) = f_rng.Areas(idx).Cells(jdx, 3).Value
       kdx = kdx + 1
       Next jdx
      Next idx
     UserForm1.ListBox1.List() = d_list()
     End If
   End If
  Application.EnableEvents = True
End Sub
'=============================================================
Function get_rng() As Range
  On Error Resume Next
  Set get_rng = Nothing
  Set get_rng = rng.SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
End Function


これで、mainを実行してみてください。
尚、フィルタモードには、ユーザーフォーム表示と一緒になりますので、
フィルタモードOFFの状態で実行してみて下さい。

0 hits

【10485】リストボックスにフィルタ適用後のセル範... ハットリ 04/1/28(水) 17:03 質問
【10488】Re:リストボックスにフィルタ適用後のセル... ichinose 04/1/28(水) 21:27 回答
【10489】訂正です ichinose 04/1/28(水) 23:03 発言

70752 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free