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

Question

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

happypoint · Accepted Answer

こんばんは。#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

noname#11856 · Answer

#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を指して終わる事はできますけど。。。そういう問題じゃないのかな。。。

happypoint · Answer

こんにちは。ふたたび#1です。

＞複数検索全てにヒットするのを出力するというのは課題が重すぎました

お悩みのようですね。
複数検索条件のロジックを自前で書こうとすると、
わたしでも３日ぐらいかかってしまいそうです^^;

(蛇足ですが・・・
通常このような検索主体の機能をつけるなら、Accessを使った方が何かと便利です。
標準機能だけで複数条件を指定して検索できます。)


しかし、Excelでできないわけではありません。
ExcelVBAのいいところは、Excelがもっている便利な機能を、
おいしいところだけつまみ食いできるところです。

「オートフィルタ」の機能をご存じですか？
これは今回のようなケースのためにあるような機能です^^

これをうまく使ってやれば、複数条件による抽出の部分は、
自前でコーディングしなくても、エクセルがやってくれるはずです。

いちど、「オートフィルタ」を手作業で操作してみて、
複数条件で抽出できないか、やってみてください。


もしこれができるならば（きっとできます！）、
あとあなたが考えなければいけないのは、
テキストボックスに入力した条件をオートフィルタに渡しオートフィルタがピックアップした結果を、
別シートにコピーする処理だけです。

VBAでオートフィルタを設定する条件の書き方がわからないときは、
マクロ記録で手作業したものを開いてみれば良いでしょう。

どうですか？わかりそうですか？

happypoint · Answer

#1です。こんにちは。

＞2回目の検索の結果を1回目の検索の結果に上書きではなく、
＞その下の行から追加という形で出力

向上心が旺盛でいらっしゃいますね。^^

わたしのコードを修正する場合は、次の手順で修正してみて下さい。

（１）
まず、変数の定義に、次の行を追加してみてください。

　Static lngOffset As Long

この変数は、マクロが終わってもクリアされない「静的変数」として定義しています。
この変数で、前回の検索でシート２の何行目まで貼り付けたか、を覚えておくことができます。

（２）
つぎに、初期化のところを、こう変更します。
前のコードでは毎回1行目から貼り付けしていましたが、
今回は最終行以降に追加で貼り付けます。

　'初期化
　lngRow2 = lngOffset + 1 '前回検索して貼り付けたデータの、最終行の次の行に貼り付ける


（３）
最後に、最終行（End Subの直前）に、以下のコードを追加してください。
こうすることで、検索するごとに何行目まで貼り付けたかを記憶させることができます。

　lngOffset = lngRow2 - 1 '貼り付け先の最終行を記憶

imogasi · Answer

私は馬鹿の１つ覚えでいつも下記で考えてます。
コピーは使いません、代入で済まします。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

noname#11856 · Answer

・・・先を越されましたが、投稿。（笑）
ちょっと違うので、こんな風にもできますよー的なものとしてご参照ください。(^-^;

指摘ポイントは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

happypoint · Answer

こんにちは。

全体的に良くできていると思いますが、
気になる点がありましたので、いくつか指摘しておきます。

まず「変数の宣言」と書いてあるところですが、
これは単に変数の代入をしているに過ぎません。
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

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

こんばんは。

#4の補足に書かれているInStrを使ったIf文を下記のように変えてみても

こんにちは。

#1です。

この回答への補足

私は馬鹿の１つ覚えでいつも下記で考えてます。

・・・先を越されましたが、投稿。

こんにちは。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング