| |
検索条件を入力するシートの名前を "条件" として、
表のあるシートのシートモジュールに、以下のイベントマクロを
入れて下さい。1行目のセルのみ、ダブルクリックすると入力フォームが
出てきます。そこへ例えば 200601 と 東京 を入力すれば、抽出できる
値が見つかれば自動的にフィルターをかけます。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim Dnum As Long
Dim MySt As String
Dim Flg As Boolean
Const Pmt1 As String = _
"抽出する生年月日の年と月を yyyymm形式 で入力して下さい"
Const Pmt2 As String = _
"抽出する本籍を入力して下さい"
If Target.Row > 1 Then Exit Sub
Cancel = True
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Range("E:E").ClearContents
Range("E1").Value = "CheckDate"
With Range("B2", Range("B65536").End(xlUp)).Offset(, 3)
.Formula = "=IF(MONTH($B2)<10,YEAR($B2)&""0""&MONTH($B2)" & _
",YEAR($B2)&MONTH($B2))"
.Value = .Value
End With
With Application
Do
Dnum = .InputBox(Pmt1, Type:=1)
If Dnum = False Then GoTo ELine
Loop While Len(Dnum) <> 4
If IsError(.Match(Dnum, Range("$E:$E"), 0)) Then
Flg = True: GoTo ELine
End If
MySt = .InputBox(Pmt2, Type:=2)
If MySt = "False" Then GoTo ELine
If IsError(.Match(MySt, Range("$D:$D"), 0)) Then
Flg = True: GoTo ELine
End If
.ScreenUpdating = False
End With
On Error Resume Next
ActiveSheet.ShowAllData
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
With Worksheets("条件")
.Range("A1:B2").ClearContents
.Range("A1:B1").Value = Array("本籍", "CheckDate")
.Range("A2:B2").Value = Array(MySt, Dnum)
Range("A1").CurrentRegion.AdvancedFilter xlFilterInPlace, _
.Range("A1:B2"), , False
End With
ELine:
If Flg Then MsgBox "抽出する値が見つかりませんでした", 48
Range("E:E").ClearContents
Application.ScreenUpdating = True
End Sub
|
|
Kein
- 06/7/5(水) 19:05 -
