[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『インプットボックスを使用してのデータ抽出』（うに）
[インプットボックスを使用してのデータ抽出について教えてください]
皆様こんにちは。はじめまして。
今会社であるデータを検索するシステムを自力で作っております。こちらの教室をじっくりと参考にさせていただき､初めてのマクロ登録やコマンドボタンで､オートフィルターを使っての検索はできました。
今作っているシステムの概要です。
1つのブックに11のシート（!）があります。このうち1枚のシートがデータベースとなっており､現在157件のデータを入力しています（今後データは増えていきます）。
1行目から5行目まではコメントや見出しが入っており､データはＡ6〜入っています。
Ａ B C D E F G H I J K L M N O P Q R S T・・・・AY
１
・
・
５ NO 年 月 ・ ・ ・ ・ ・ ・ ・
６ １'99 4月 ・ ・ ・ ・ ・ ・
７ ２'99 4月 ・ ・ ・ ・ ・ ・
・
・
・
157
といった具合に､A6〜AY162までが実際のデータ範囲です。
このなかで、P列からS列に入っている語句をインプットボックスで入力､行単位のデータを抽出したいのです。
あまりパソコンに親しんでいない人たちが検索できるよう、インプットボックスに入力した語句を含むデータが抽出されるまでをマクロで作りたいと思い､こちらの教室で近いものをいくつかコピペ＆加工してみようとしましたが､ぜんぜんうまくいきませんでした。
抽出したデータは別シートに転記されても良いし､オートフィルターで抽出したようにデータベース上に抽出されたものだけが残る形でもかまいません。
あまり上手に説明できていないとは思いますが､どなたか助けてください。
よろしくお願いします。
例えばこんな塩梅に？
Sheet1のデータを検索してSheet2に抽出しとります。
（弥太郎）
'------------------------
Sub uni()
Dim j As Integer, n As Integer, y As Integer, i As Long
Dim data As String, tbl
With Sheets("sheet1")
tbl = .Range("a6").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 51).Value
data = Application.InputBox("検索するのは？", "検索", Type:=2)
End With
ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2))
For i = 1 To UBound(tbl, 1)
For n = 16 To 19
If tbl(i, n) Like "*" & data & "*" Then
y = y + 1
For j = 1 To UBound(tbl, 2)
x(y, j) = tbl(i, j)
Next j
End If
Next n
Next i
If y = 0 Then MsgBox "該当するデータはおまへん！": Exit Sub
With Sheets("sheet2")
.Cells.Clear
.Cells(1, 1).Resize(y, UBound(tbl, 2)) = x
End With
End Sub
早速のご回答ありがとうございます。うにです。
すごいです！何日も止まってたのがうそみたいです。
あと､もう少し教えてください。
Sheet１にはシート保護をかけてあります。保護を解除したあと､もう一度保護をかけるのはどのタイミング（?）で入れたらいいのでしょうか?
またSheet2に転記する際､Sheet1の書式設定ごと転記したいのです。Sheet2のA6からデータを書式ごとの転記ということになります。で、そのSheet2を指定してプロシージャを終わる形にしたいと思っています。
いろいろ申し上げてすみません。
弥太郎さんからレスをつけていただけるなんて､嬉しくて嬉しくて。。。
甘えてしまっていますが､どうぞよろしくお願いいたします。
あのねぇうにさん、そんなに持ち上げなはんな（笑
Sheet1に保護がかかっていようがいまいがデータを変更する訳やおまへんからこのマク
ロに関係おまへん。
With Sheets("sheet2")
.Cells.ClearContents
.Cells(1, 1).Resize(y, UBound(tbl, 2)) = x
.Select
End With
こう変更するとセルの書式設定はそのまま保たれ、Sheet2をアクティブにして終了
します。
（弥太郎）
ありがとうございます！
ただ、残念ながらｼｽﾃﾑを家に持ち帰ることが出来ませんので、(明日は休暇をとっているため)土曜日の午後に早速試してみます。
それからまたご報告しますね。
本当にありがとうございます!!
うにです。ご報告が遅れて申し訳ありません。
ありがとうございます！！
私が目指していたものが形になりました。
今のところ､このシステムは完成です。
弥太郎さんのおかげです。本当にありがとうございました!!
先日完成したはずのシステムに手直しを言い渡され途方に暮れております。またこちらに助けていただきたくお邪魔しました。
検索するキーワードをインプットボックスで手入力するのではなく､コンボボックスから選択させるにはどうしたらよいのでしょうか?
現在ユーザーフォーム1にコンボボックスを作っている状態です。
このコンボボックスで選んだ語句を先に作ったインプットボックスに反映させたいと思っています。
たびたびで申し訳ありませんが､ご教示ください。よろしくお願いいたします。
コマンドボタンとコンボボックスを配置
そのフォームモジュールに
下のコードをコピペ
今から出かけます。（弥太郎）
Private Sub CommandButton1_Click()
Dim j As Integer, n As Integer, y As Integer, i As Long
Dim data As String, tbl
With Sheets("sheet1")
tbl = .Range("a6").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 51).Value
data = ComboBox1.Value
End With
ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2))
For i = 1 To UBound(tbl, 1)
For n = 16 To 19
If tbl(i, n) = data Then
y = y + 1
For j = 1 To UBound(tbl, 2)
x(y, j) = tbl(i, j)
Next j
End If
Next n
Next i
If y = 0 Then MsgBox "該当するデータはおまへん！": Exit Sub
With Sheets("sheet2")
.Cells.Clear
.Cells(1, 1).Resize(y, UBound(tbl, 2)) = x
End With
End Sub
Private Sub UserForm_Initialize()
With ComboBox1
For Each c In Sheets("sheet1").Range("p6").Resize(Range _
("a" & Rows.Count).End(xlUp).Row, 4)
.AddItem c
Next c
End With
End Sub
ホントにホントにありがとうございました。
あの。。。それで、ここで作ったコンボボックスのリストの中で重複するものと空白を表示させないためにはどうしたらよいのですか?
申し訳ありませんが､どうぞよろしくお願いいたします。
こんな塩梅でっか？
（弥太郎）
'-------------------
Private Sub UserForm_Initialize()
Dim dic As Object, c, ky, tbl
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("p6").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 4).Value
End With
With ComboBox1
For Each c In tbl
If Not IsEmpty(c) Then
dic(c) = Empty
End If
Next c
For Each ky In dic.keys
.AddItem ky
Next ky
End With
Set dic = Nothing
End Sub
うにです。師匠の犬と呼んでください。
あの､あの､リストの中身を五十音で整列させることはできますか?
あのねぇうにさん、わたしになんか恨みでもありまんのんか？（笑
「もうお食事タイムやと耳を引っ張られてます。
せやから、腹満腹＆酩酊状態で考えてみますワ、・・・ぶつぶつ・・・ぶつぶつ・・・
（弥太郎）
あれ、うにさん、その晩にカキコした筈なんですけど、見まへんでしたぁ？？？
ま、ええわ、ゴミ箱あさって拾い出してきましたワ。（笑
（弥太郎）
'---------------------
Private Sub UserForm_Initialize()
Dim dic As Object, c, ky, tbl
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet1")
tbl = .Range("p6").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 4).Value
End With
ReDim x(1 To UBound(tbl, 1) * 4, 1 To 1)
For Each c In tbl
If Not IsEmpty(c) Or Not dic.exists(c) Then
i = i + 1
dic(c) = Empty
x(i, 1) = c
End If
Next c
Sheets.Add
With ActiveSheet
.Cells(1, 1).Resize(i) = x
.Range("a1").Resize(i).Sort key1:=.Range("a1"), order1:=xlAscending, MatchCase:=False, _
sortmethod:=xlPinYin
tbl = .Cells(1, 1).Resize(i).Value
Application.DisplayAlerts = False
.Delete
End With
With ComboBox1
For i = 1 To UBound(tbl, 1)
.AddItem tbl(i, 1)
Next i
End With
Set dic = Nothing
Application.DisplayAlerts = True
End Sub
Private Sub CommandButton1_Click()
Dim j As Integer, n As Integer, y As Integer, i As Long
Dim data As String, tbl
With Sheets("sheet1")
tbl = .Range("a6").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 51).Value
data = ComboBox1.Value
End With
ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2))
For i = 1 To UBound(tbl, 1)
For n = 16 To 19
If tbl(i, n) = data Then
y = y + 1
For j = 1 To UBound(tbl, 2)
x(y, j) = tbl(i, j)
Next j
End If
Next n
Next i
If y = 0 Then MsgBox "該当するデータはおまへん！": Exit Sub
With Sheets("sheet2")
.Cells.Clear
.Cells(1, 1).Resize(y, UBound(tbl, 2)) = x
.Select
End With
End Sub
こんにちは､うにです。お師匠様がカキコして下さっていたのに申し訳ありません。
ひどい風邪を引いて寝込んでおりました。今日やっと会社に出てきました。
早速コピペして使わせていただきました。
のですが。。。
50音順にキーワードが並び替えされていましたが､重複するものがそのまま出てきてしまいました。
お師匠様､何とか何とかもう一度お力を貸してください。
よろしくお願いします。
うにさん遅くなって申し訳ありまへ〜ん。ひどい風邪を引いて寝込んでおりました〜。 っちゅうのはウソでして、単に忙しかっただけです、ハイ。（笑 If Not IsEmpty(c) Or Not dic.exists(c) Then とあるのを If Not IsEmpty(c) And Not dic.exists(c) Then に入れ替え（書き換えでも可）してみておくんなはれ、それでOKですワ。 でけまっか？ （弥太郎）
でっきました〜！
ありがとうございます。ありがとうございます。
お師匠様にマクロを作っていただいたおかげで、システムとして機能させることができます♪
本当にありがとうございました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.