エクセルVBAで検索してシートへ貼り付け。

質問

どうも。
エクセルでVBAをやっています。

表に映画のデータベースのように打ち込んで
VBAフォームでタイトルを検索して、ヒットした行を別シートに出力するというのがやりたいのですが、できないのです。

Private Sub CommandButton1_Click()
'変数の宣言
strTitle = ""
intEndIndex = 0
intTate = 1
intYoko = 1

With Workbooks("book1.xls").Sheets(1)
strTitle = UserForm3("TextBox1")

i = 1
Do Until .Cells(i, 1) = ""
i = i + 1
Loop
'A1から下へ空白がでるまで検索する感じです。
intEndIndex = i - 1
Do Until intTate > intEndIndex
If strTitle = "" Then
Exit Do
ElseIf InStr(1, .Cells(intTate, intYoko), strTitle) > 0 Then
End If
intTate = intTate + 1
Loop
End With
End Sub

検索することはできるのですが、
ヒットした行（タイトルや監督や制作年、出演者などが表に書いてある)を別シートに貼り付ける方を教えてください。
よろしくお願いします。

回答No.6

happypoint · ベストアンサー

こんばんは。#1です。
どうでしょうか。考えはまとまりました？

わたしの方でもなんとかならないかと考えてみました。
#5で回答した中にあった、オートフィルタを使って、
リストをピックアップするサンプルです。
なにか参考になればと思います。

条件として、A,B,C,D,Eの各列に
　タイトル、制作年、監督、主演、ジャンル
が入力されているものとします。
１行目は見出しの行であるものとし、
２行目以降から映画のデータが入っていることとします。

フォームには、５つのテキストボックス（TextBox1～5）と、
ひとつのコマンドボタン(CommandButton1)を用意しました。

TextBox1が、「タイトル」の検索用文字列を入力するボックスとし、
以下、制作年、監督、主演、ジャンルを５つのテキストボックスに入力するものとします。

※質問ではコンボボックスとなっていましたが、
テキストボックスで作りましたので、適宜作り替えてみてください。

検索は、キーワードに完全に一致するものを抽出します。
部分一致検索にしたいときは、キーワードにワイルドカードを指定します。
たとえば、「*ニック」と入力すると「タイタニック」がヒットします。

ヒットした映画のデータを、
コピーペーストするところまでのコードは書いていませんが、
このコードが理解できれば道のりはそう遠くないはずです。
がんばってみてください^^。

Private Sub CommandButton1_Click()
Dim txtCriteria(1 To 5) As String '検索キーワード
Dim i As Long 'ループ用

'オートフィルタモードのオン
Selection.AutoFilter

'TextBoxの値を取得（5回ループ）
For i = LBound(txtCriteria) To UBound(txtCriteria)

　'TextBoxの検索文字列を取得
　txtCriteria(i) = Me.Controls("Textbox" & i).Value

　'キーワード文字列にあうものを抽出（条件入力時のみ）
　If Len(txtCriteria(i)) > 0 Then
　　　Selection.AutoFilter Field:=i,　Criteria1:=txtCriteria(i)
　End If

Next i

End Sub

お礼

こんにちは。回答ありがとうございます。
またまた返事が遅れてしまい申し訳ございません。

オートフィルタなんてすごい機能があったのですね。
ちょっと敷居が高いですが、挑戦してみました。
happypointさんのサンプルで抽出することは上手くできたのですが、シートへの貼り付けが出来ないです><;。
今までのを全部振り返りながらやっているのですが、
思ったようにできなくて困ってます。
でも、今まででみなさんにかなりのアドバイスを頂いたので、あとは自分で頑張ろうと思います。
今の段階では基礎が出来てないなのでコードの一つ一つの意味を理解するのに時間がかかり、皆さんに迷惑かけてしますので、一から学習しながら作り上げたいと思います。
基礎を身につけたうえで、また分からないことがあったら質問させていただきます。
親身にアドバイスしてくださいまして非常に嬉しく感謝しております。本当に有難うございました。

回答No.7

noname#11856

#4の補足に書かれているInStrを使ったIf文を下記のように変えてみても
うまくいかないでしょうか？
・・・風邪ひいてぼーっとした頭なのでなんだかよくわかりませんが。（笑）

If (strTitle = "" Or InStr(1, .Cells(lngRow1, lngYoko).Value, strTitle) > 0) And _
(strYear = "" Or InStr(1, .Cells(lngRow1, 2).Value, strYear) > 0) And _
(strKantoku = "" Or InStr(1, .Cells(lngRow1, 3).Value, strKantoku) > 0) And _
(strShuen = "" Or InStr(1, .Cells(lngRow1, 4).Value, strShuen) > 0) And _
(strGenre = "" Or InStr(1, .Cells(lngRow1, 5).Value, strGenre) > 0) Then

あと、#2のお礼欄に書かれてるC6が選択される・・・というのは
なんでしょうね？ そうなるように作った覚えはないんですけど。（笑）
えー・・・Sheets(2).Selectの前に、.Range("A1").Selectとでもしておけば
常にA1を指して終わる事はできますけど。。。そういう問題じゃないのかな。。。

お礼

こんにちは。回答ありがとうございます。

サンプルのとおりにしたのですが、コマンドボタンを押下しても何の反応もしませんでした。
基礎が出来ていないので、どう直したらいいか分からないので、一から勉強してやってみます。
Ｃ６が選択されるのは何でしょうね。コードに何かまぎれてるかもしれないです。そういうのが分かるように頑張っていきたいと思います。
色々アドバイスくださいましてありがとうございます。
最近、朝が寒くて僕も風邪ひきかけています^^。
お大事にしてくださいね。
有難うございました。

回答No.5

happypoint

こんにちは。ふたたび#1です。

＞複数検索全てにヒットするのを出力するというのは課題が重すぎました

お悩みのようですね。
複数検索条件のロジックを自前で書こうとすると、
わたしでも３日ぐらいかかってしまいそうです^^;

(蛇足ですが・・・
通常このような検索主体の機能をつけるなら、Accessを使った方が何かと便利です。
標準機能だけで複数条件を指定して検索できます。)

しかし、Excelでできないわけではありません。
ExcelVBAのいいところは、Excelがもっている便利な機能を、
おいしいところだけつまみ食いできるところです。

「オートフィルタ」の機能をご存じですか？
これは今回のようなケースのためにあるような機能です^^

これをうまく使ってやれば、複数条件による抽出の部分は、
自前でコーディングしなくても、エクセルがやってくれるはずです。

いちど、「オートフィルタ」を手作業で操作してみて、
複数条件で抽出できないか、やってみてください。

もしこれができるならば（きっとできます！）、
あとあなたが考えなければいけないのは、
テキストボックスに入力した条件をオートフィルタに渡しオートフィルタがピックアップした結果を、
別シートにコピーする処理だけです。

VBAでオートフィルタを設定する条件の書き方がわからないときは、
マクロ記録で手作業したものを開いてみれば良いでしょう。

どうですか？わかりそうですか？

回答No.4

happypoint

#1です。こんにちは。

＞2回目の検索の結果を1回目の検索の結果に上書きではなく、
＞その下の行から追加という形で出力

向上心が旺盛でいらっしゃいますね。^^

わたしのコードを修正する場合は、次の手順で修正してみて下さい。

（１）
まず、変数の定義に、次の行を追加してみてください。

　Static lngOffset As Long

この変数は、マクロが終わってもクリアされない「静的変数」として定義しています。
この変数で、前回の検索でシート２の何行目まで貼り付けたか、を覚えておくことができます。

（２）
つぎに、初期化のところを、こう変更します。
前のコードでは毎回1行目から貼り付けしていましたが、
今回は最終行以降に追加で貼り付けます。

　'初期化
　lngRow2 = lngOffset + 1 '前回検索して貼り付けたデータの、最終行の次の行に貼り付ける

（３）
最後に、最終行（End Subの直前）に、以下のコードを追加してください。
こうすることで、検索するごとに何行目まで貼り付けたかを記憶させることができます。

　lngOffset = lngRow2 - 1 '貼り付け先の最終行を記憶

お礼

早速の回答ありがとうございます。
できました。感動ですね^^。

回答読みながら「こうゆう手順でやるのかぁ」
とただただ驚くばかりです。
はやくhappypointさんのような考えが浮かぶようになりたいです。

まだまだ初心者の私は複数検索全てにヒットするのを出力するというのは課題が重すぎました。色々奮闘したのですが、これ以上考えがでてこない感じです。
ですので、御教授いただけると嬉しいです。
長くなるので補足に記入しときます。

ありがとうございました。

補足

はじめに回答くださったみなさんありがとうございました。
タイトルだけを検索して出力する方法をみなさんに教えていただき、それを応用して複数検索しようと挑んだのですが、まったくわからなくまた質問させていただきます。

フォームにはテキストボックス（タイトル、制作年、監督、主演）が4つとコンボボックス（ジャンル）が1つあって、その５つに入力した文字すべてと一致するものを出力したいのです。No.1の方の回答をもとに

Const lngTate As Long = 1 '行番号
Const lngYoko As Long = 1 'タイトルの列番号(固定)
Dim lngMaxRow As Long 'データの最終行
Dim lngRow1 As Long '貼り付けもとの行
Dim lngRow2 As Long '貼り付け先の行
Dim strTitle As String
Dim strYear As String
Dim strKantoku As String
Dim strShuen As String
Dim strGenre As String
Static lngOffset As Long

With Workbooks("book2.xls").Sheets(1)
strTitle = TextBox1.Value
strYear = TextBox2.Value
strKantoku = TextBox3.Value
strShuen = TextBox4.Value
strGenre = ComboBox1.Value

'初期化
lngRow2 = lngOffset + 1

'Textの取得
If TextBox1.Value = "" Then Exit Sub
strTitle = TextBox1.Value

If TextBox2.Value = "" Then Exit Sub
strYear = TextBox2.Value

If TextBox3.Value = "" Then Exit Sub
strKantoku = TextBox3.Value

If TextBox4.Value = "" Then Exit Sub
strShuen = TextBox4.Value

If ComboBox1.Value = "" Then Exit Sub
strGenre = ComboBox1.Value

'項目数を把握
Worksheets(1).Select
Cells(ActiveSheet.Rows.Count, lngYoko).End(xlUp).Select
lngMaxRow = Selection.Row

'検索して合致したらコピペ
For lngRow1 = 1 To lngMaxRow
If InStr(1, Cells(lngRow1, lngYoko).Value, strTitle) > 0 _
And InStr(1, Cells(lngRow1, 2).Value, strYear) > 0 _
And InStr(1, Cells(lngRow1, 3).Value, strKantoku) > 0 _
And InStr(1, Cells(lngRow1, 4).Value, strShuen) > 0 _
And InStr(1, Cells(lngRow1, 5).Value, strGenre) > 0 Then
Rows(lngRow1).Copy
Sheets(2).Cells(lngRow2, 1).PasteSpecial
lngRow2 = lngRow2 + 1
End If
Next lngRow1

'結果の表示
Worksheets(2).Select

lngOffset = lngRow2 - 1

End With
End Sub

というところまでやったのですが、これだと全てのボックスに文字を入力しないと検索できません。
一つでも未記入のボックスがあると検索ボタンを押しても反応なしです。
　InStr(1, Cells(lngRow1, lngYoko).Value, strTitle) > 0
が0なので空白だと一致しないというのは分かるのですが、空白ボックスがあっても検索できて、なおかつ入力した文字が全て含まれているものだけを出力したいのです。

例えば、タイトル「タイタニック」、制作年「1998」、監督「ジェームスキャメロン」、主演「レオナルド・ディカプリオ」、ジャンル「恋愛」という行があって、
タイトル「タイタニック」・ジャンル「恋愛」（制作年、監督、主演は未入力)と入力して他の行にジャンル「恋愛」のものがあってもタイタニックのみヒットさせたいのです。

非常に長くなってすいませんが、よろしくお願いいたします。

回答No.3

imogasi

私は馬鹿の１つ覚えでいつも下記で考えてます。
コピーは使いません、代入で済まします。CurrentRegionはクセがあるかもしれません。
文字数の多いDIMによる定義は、本当はすべきなんですが
、読みづらいだろうと勝手に１文字を多用してます。
Sub test01()
Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
j = 1 'Sheet2のデータをセットする始まり行
u = 2 'Sheet1のデータ部の始まり行
d = sh1.Cells(u, 1).CurrentRegion.Rows.Count
s = InputBox("検索文字列=")
For i = u To u + d
If InStr(Cells(i, 1), s) <> 0 Then
　For k = 1 To 4 'D列までデータがあると仮定
　sh2.Cells(j, k) = sh1.Cells(i, k)
　Next k
　j = j + 1
End If
Next i
End Sub

お礼

回答ありがとうございます。
お返事遅れてしまいごめんなさい。会社からつないでるんで。
VBAをはじめたばかりであんまり分からないですが、できなかったです。
Sub Test01のとこをSub CommandButton1_Click()として入力すればいいんですか。
それでやると
d = sh1.Cells(u,1).CurrentRegion.Rows.Count
のとこがエラーになって「オブジェクトが必要です」となります。
どこを変えたらいいのかも全然わからずです。
勉強不足なので誠に申し訳ないです。

回答No.2

noname#11856

・・・先を越されましたが、投稿。（笑）
ちょっと違うので、こんな風にもできますよー的なものとしてご参照ください。(^-^;

指摘ポイントはhappypointさんを同じです。

行の変数をIntegerからLongにしているのは、Excelは最大65536行ありますので
Integer（整数）型では処理し切れなくなる可能性があるためです。
・・・多分、そこまで入れないんでしょうけど・・・。

Private Sub CommandButton1_Click()
'変数の宣言
Dim strTitle As String '検索対象文字列
Dim lngCRow As Long 'コピー元行
Dim lngPRow As Long 'コピー先行

'検索対象文字列の取得
strTitle = UserForm3("TextBox1").Value
If strTitle = "" Then Exit Sub

With Worksheets(1)
lngCRow = 1
lngPRow = 1
'A列が空になるまでループ
Do Until IsEmpty(.Cells(lngCRow, 1))
If InStr(.Cells(lngCRow, 1).Value, strTitle) > 0 Then
.Rows(lngCRow).Copy
Worksheets(2).Cells(lngPRow, 1).PasteSpecial
Application.CutCopyMode = False 'コピー時の枠がうじゃうじゃしてるのを止める（笑）
lngPRow = lngPRow + 1
End If
lngCRow = lngCRow + 1
Loop
End With
End Sub

お礼

回答ありがとうございます。
お返事遅れてすいません。会社からここにつないでいるもので。Long型にするのはそうゆうことなんですね。そのぐらいデータいれるぐらい映画を知ろうと思います^^。
非常に簡潔なコードありがとうございます。
無事に検索できました。
質問なのですが、検索終わったときにシート１のセルＣ６がセレクトされるのはどうしてでしょうか？あと、2回目の検索の結果を1回目の検索の結果に上書きではなく、その下の行から追加という形で出力するのはどのようにするのでしょうか？
また質問しちゃってすいません。
ありがとうございました。

回答No.1

happypoint

こんにちは。

全体的に良くできていると思いますが、
気になる点がありましたので、いくつか指摘しておきます。

まず「変数の宣言」と書いてあるところですが、
これは単に変数の代入をしているに過ぎません。
Dim文を使って、型を宣言しましょう。

つぎに
　strTitle = UserForm3("TextBox1")
ですが、
　strTitle = TextBox1.Value
と明確に値（テキスト）を代入したほうがいいと思います。

それからDo-Loopで処理している部分が多いのですが、
もうちょっと処理の構造を見直したほうがいいですよ。
できるならFor-Nextを使ったほうが、無限ループに陥る可能性がなくなります。

わたしなりに、書き直したものを乗せておきます。
参考にしてみてください。

Option Explicit

Private Sub CommandButton1_Click()
'変数の宣言
Const lngYoko As Long = 1 'タイトルの列番号（固定）
Dim lngMaxRow As Long 'データの最終行
Dim lngRow1 As Long '貼り付けもとの行
Dim lngRow2 As Long '貼り付け先の行
Dim strTitle As String 'テキストボックスの文字列

'初期化
lngRow2 = 1

'Textの取得
If TextBox1.Value = "" Then Exit Sub
strTitle = TextBox1.Value

'項目数を把握
Worksheets(1).Select
Cells(ActiveSheet.Rows.Count, lngYoko).End(xlUp).Select
lngMaxRow = Selection.Row

'検索して合致したらコピペ
For lngRow1 = 1 To lngMaxRow
　If InStr(1, Cells(lngRow1, lngYoko).Value, strTitle) > 0 Then
　　Rows(lngRow1).Copy
　　Sheets(2).Cells(lngRow2, 1).PasteSpecial
　　lngRow2 = lngRow2 + 1
　End If
Next lngRow1

'結果の表示
Worksheets(2).Select
End Sub

お礼

回答ありがとうございます。
お返事遅れてすいませんです。会社からやっているもんで、対応が遅れてしまいました。
Dimを使って宣言をするんですね。VBAは勉強し始めたばかりなのでほとんどわからないです。型宣言しないとVariant型にはいってしまうのですね。
happypointさんのおっしゃるとおりFor-Next文使ったほうがいいですね。試行錯誤しているとき何度も無限ループに陥りました^^。
すごい分かりやすい説明ありがとうございました。検索して貼り付けることができました。
最終目標はテキストボックスが5つ(タイトル、制作年、監督、主演、ジャンル)とあって、テキストボックスに記入した文字列に全てヒットしたデータだけ出力するというのが目標なのですが、まだまだ遠いです。
1行のを教えていただいたので応用して頑張りたいと思います。もしまたつまづいてしまったら質問させてもらいますので、そのときはよろしくお願いします。