| |
うくれれ さん
こんばんは
少し長いですが、がんばって下さい。
>「データベースの配列」
>No. 氏名 登録番号１ 登録番号２ 登録日 発効日 登録型
>１ XXXX 9999 9999 171001 171002 A-1
>２ ・ ・ ・ ・ ・ ・
>３ ・ ・ ・ ・ ・ ・
>
>そこで、抽出用にユーザフォームを作り上記データベースの各列に対応するテキストボックス又はリストボックスを配置し、条件（複数指定可）を入力してコマンドボタンクリックでフィルタをかける、なんていうことは可能でしょうか。
>例えば、登録日が170901で登録型がB-2の行をすべて抽出して表示したり、氏名>XXXXの入力された行を抽出して表示する、というように・・・。
下記の準備をして下さい。
UserForm
1）TEXTBOX 1〜7
2) LISTBOX1
3）COMMANDBUTTON 1,2
TEXTBOX1--No
TEXTBOX2--氏名
TEXTBOX3--登録番号1
TEXTBOX4--登録番号2
TEXTBOX5--登録日
TEXTBOX6--発効日
TEXTBOX7--登録番号登録型
COMMANDBUTTON1--検索ボタン
COMMANDBUTTON2--リスト全表示ボタン
に対応しています。
シート構成
作業 というシートを追加して下さい。
Sheet1の3行目A列〜G列まで下記の見出しがあるものとします。
No・氏名・登録番号1・登録番号2・登録日・発効日・登録型
Noは必ず入力されているものとします。
作業というシートは何もしなくていいです。
もし検索できなかったら作業というシートのセルの書式を全部文字列にして下さい。
下記のコードを入力またはコピーして下さい。
各TEXTBOXに検索する文字を入力して検索ボタンクリックして下さい。
検索結果がLISTBOXに表示されます。
リスト全表示ボタンをクリックすると全リストが表示されます。
確認してみて下さい。
確認後、UserForm・シートは、うくれれさんの環境に合わせて下さいね。
'---------------------------------------
Option Explicit
'---------------------------------------
Private Sub CommandButton1_Click()
'-----検索-----
Dim mySHI As Worksheet '作業シート
Dim myRhani As Range '抽出元範囲
Dim myRjouken As Range '抽出条件範囲
Dim myK1 As String 'TEXTBOX1
Dim myK2 As String 'TEXTBOX2
Dim myK3 As String 'TEXTBOX3
Dim myK4 As String 'TEXTBOX4
Dim myK5 As String 'TEXTBOX5
Dim myK6 As String 'TEXTBOX6
Dim myK7 As String 'TEXTBOX7
Dim LASROW As Long '最後のセル
Dim myDRange As String 'リスト表示範囲
ListBox1.ListIndex = -1
myK1 = TextBox1.Value 'No
myK2 = TextBox2.Value '氏名
myK3 = TextBox3.Value '登録番号1
myK4 = TextBox4.Value ' '登録番号2
myK5 = TextBox5.Value '登録日
myK6 = TextBox6.Value '発効日
myK7 = TextBox7.Value '登録型
Set mySHI = Worksheets("作業")
mySHI.Cells.Clear
With Worksheets("Sheet1")
Set myRhani = .Range(.Range("A3"), .Range("A65536").End(xlUp).Offset(0, 6)) '抽出元範囲
Set myRjouken = mySHI.Range("A1:G2") '抽出条件範囲
'抽出条件をセル範囲上に入力する
mySHI.Range("A1").Value = .Range("A3").Value 'No フィールドを指定"
mySHI.Range("B1").Value = .Range("B3").Value '氏名 フィールドを指定"
mySHI.Range("C1").Value = .Range("C3").Value '登録番号1 フィールドを指定"
mySHI.Range("D1").Value = .Range("D3").Value '登録番号2 フィールドを指定"
mySHI.Range("E1").Value = .Range("E3").Value '登録日 フィールドを指定"
mySHI.Range("F1").Value = .Range("F3").Value '発効日 フィールドを指定"
mySHI.Range("G1").Value = .Range("G3").Value '登録型 フィールドを指定"
End With
With mySHI
If TextBox1.Value = "" Then
.Range("A2").Value = myK1 '抽出条件を指定
Else
.Range("A2").Value = "'=" & myK1 '抽出条件を指定
End If
If TextBox2.Value = "" Then
.Range("B2").Value = myK2 '抽出条件を指定
Else
.Range("B2").Value = "'=" & myK2 '抽出条件を指定
End If
If TextBox3.Value = "" Then
.Range("C2").Value = myK3 '抽出条件を指定
Else
.Range("C2").Value = "'=" & myK3 '抽出条件を指定
End If
If TextBox4.Value = "" Then
.Range("D2").Value = myK4 '抽出条件を指定
Else
.Range("D2").Value = "'=" & myK4 '抽出条件を指定
End If
If TextBox5.Value = "" Then
.Range("E2").Value = myK5 '抽出条件を指定
Else
.Range("E2").Value = "'=" & myK5 '抽出条件を指定
End If
If TextBox6.Value = "" Then
.Range("F2").Value = myK6 '抽出条件を指定
Else
.Range("F2").Value = "'=" & myK6 '抽出条件を指定
End If
If TextBox7.Value = "" Then
.Range("G2").Value = myK7 '抽出条件を指定
Else
.Range("G2").Value = "'=" & myK7 '抽出条件を指定
End If
End With
'検索-検索結果を作業シートにコピー
myRhani.AdvancedFilter _
Action:=xlFilterCopy, CriteriaRange:=myRjouken, _
copytorange:=Worksheets("作業").Range("A5")
'検索結果をリスト表示
LASROW = Worksheets("作業").Range("A65536").End(xlUp).Row
myDRange = "作業!A6:G" & LASROW
ListBox1.RowSource = myDRange
If Worksheets("作業").Range("A6").Value = "" Then
ListBox1.RowSource = ""
End If
End Sub
'---------------------------------------
Private Sub CommandButton2_Click()
'-----リスト全表示-----
Dim f As Long
ListBox1.ListIndex = -1
Worksheets("作業").Cells.Clear
For f = 1 To 7
Controls("TEXTBOX" & f).Value = ""
Next
Call S_LIST '初期リスト表示
End Sub
'---------------------------------------
Private Sub UserForm_Initialize()
'-----USERFORM初期設定-----
Dim LASROW As Long
Dim mySHI As Worksheet
Dim f As Long
With ListBox1
.ColumnCount = 7
.ColumnWidths = "50;50;50;50;50;50;50"
End With
Call S_LIST '初期リスト表示
End Sub
'---------------------------------------
Private Sub S_LIST()
'-----初期リスト表示------
Dim LASROW As Long
Dim myDRange As String
LASROW = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
myDRange = "Sheet1!A4:G" & LASROW
ListBox1.RowSource = myDRange
If Worksheets("Sheet1").Range("B4").Value = "" Then
ListBox1.RowSource = ""
End If
End Sub
'---------------------------------------
|
|
Lion
- 05/10/2(日) 18:33 -
