【至急】エクセルで複数のファイルから文字列を検索、行全てを抽出する

お助けください。
当方Excel初心者です。表などは作成したことがあるものの、マクロや関数にはうといです。
仕事の関係で、複数のExcelファイルから、文字列を検索して、その文字列が含まれる行を他のファイルに抽出したいのですが、調べてみてもなかなかうまくいきませんでした。

例えば
A　　　　B　　　　　　C
商品名　　商品コード　価格
だいこん　000000　　100
きゅうり　111111　　50
にんじん　222222　　50
レタス　　333333　　100

などが入っているシートがたくさんあり、それがショップごとにファイル分けされています。
それらのファイルは同一のフォルダ内にあり、その中からたとえば「きゅうり」と検索したら、
AからCまでのデータが抽出できるようにしたいのです。

色々調べてみて、検索した言葉のセルだけは抽出できたのですが、
行全体までは抽出できませんでした。
どなたかお知恵を拝借させてください。

作業環境　Windows7
使用Excel　2013


ちなみにセルのみ抽出できたコードは以下になります。

Sub Search()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet

Set WS = Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With

Str = Application.InputBox(prompt:="検索文字列:", Title:="今指定したフォルダにある全Excelファイルを検索します", Type:=2)

If Str = "False" Then Exit Sub
If Str = "" Then Exit Sub

WS.Range("A1") = "検索文字列:"
WS.Range("B1") = Str
WS.Range("A2") = "パス:"
WS.Range("B2") = myfolder
WS.Range("A3") = "ファイル名"
WS.Range("B3") = "シート名"
WS.Range("C3") = "検索結果"

a = 0

Application.ScreenUpdating = False

Value = Dir(myfolder)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
On Error Resume Next
Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
If Err.Number > 0 Then
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
a = a + 1
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets

'セルの文字列に完全マッチしたいならxlWholeを使う。部分マッチしたいならxlPartを使う。
' Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not c Is Nothing Then
firstAddress = c.Address
Do
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = sht.Name
WS.Range("C4").Offset(a, 0).Value = c.Value
a = a + 1
Set c = sht.Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop

Application.ScreenUpdating = True

Cells.EntireColumn.AutoFit
End Sub

No.4 ベストアンサー 回答者： WindFaller 回答日時： 2017/03/23 10:19

こんにちは。

初心者にしては、ずいぶん込み入ったものをお作りなりますね。
お世辞抜きで、初心者でしたら出来過ぎです。
内容もよくできているように思いますが、ただ、今の時点では解決できない問題も含まれていますので、なかなか厄介です。

また、初心者として名乗れる間に、初歩的な部分は直しておいたほうがよいことがあります。特に、Value はプロパティ名ですから、それでエラーにはならないにしても、使い勝手がよくありません。また、Str というのは、UserFormのTextBox に使う関数名です。VB.Net では自由ですが、VBAは、VB6のDNAがあるので、あまり良くありません。カウンター変数は、「i」から始まるとか……。

変数は、ある程度の決まりがありますから、それを逸脱すると、あとでややこしいことになります。（必ずしも、私が守っているとは言い切れませんが、ちゃんとした変数の付け方をしている人はエラーの度合いも少ないです。）

参考は、Excel大辞典　（ただし以下の内容は、古いですから、全部を真似ることはありません。理由を述べると長くなりますが、MS社では、この書き方を現在は推進していません。）
http://home.att.ne.jp/zeta/gen/excel/c04p15.htm

私が書き直してみましたが、以下には、はっきりとした欠陥がひとつあります。パスワードエラーを認めていません。パスワード付きとパスワードなしのブックのみで、そもそもオープン時のエラーを対処するコードを今の時点では思いつかなかったのです。すべてに同じパスワードが入っている場合は、問題がありません。したがって、ファイルオープン時のエラーについては、記録することができません。


'///
Option Explicit
Const MPSWD As String = "ZZZZ" 'パスワードはコードの外に置きます
Sub SeartchingWordsPrc()
　Dim wb As Workbook
　Dim myFolder As String
　Dim strTxt　As String
　Dim i As Long, c As Variant
　Dim sh As Worksheet
　Dim mySh As Worksheet
　Dim Fname As Variant
　Dim FirstAddress As String
　
　Set mySh = Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count))
　''Set mySh = ThisWorkbook.ActiveSheet 'アクティブシートの場合
　With Application.FileDialog(msoFileDialogFolderPicker)
　　If .Show Then
　　　myFolder = .SelectedItems(1) & "\"
　　End If
　End With
　If Trim(myFolder) = "" Then Exit Sub
　strTxt = Application.InputBox(prompt:="検索文字列:", Title:="今指定したフォルダにある全Excelファイルを検索します", Type:=2)
　If strTxt = "False" Or strTxt = "" Then Exit Sub
　
　With mySh 'ここはまとめました*
　　.Range("A1").Resize(, 2).Value = Array("検索文字列:", strTxt)
　　.Range("A2").Resize(, 2).Value = Array("パス:", myFolder)
　　.Range("A3").Resize(, 3).Value = Array("ファイル名:", "シート名:", "検索結果")
　End With
　
　i = 4 '初期行設定
　On Error GoTo errHandler
　
　Application.ScreenUpdating = False
　''----Start -----
　Fname = Dir(myFolder & "*.xls?", vbNormal)
　
　Do Until Fname = ""
　　If Fname <> "." And Fname <> ".." Then
　　　Application.DisplayAlerts = False
　　　Set wb = Workbooks.Open(myFolder & Fname, , Password:="", WriteResPassword:="")
　　　Application.DisplayAlerts = True
　　　If wb Is Nothing Then
　　　　With mySh　'ここが生きていません。*
　　　　　.Cells(i, "A").Value = Fname
　　　　　.Cells(i, "B").Value = "Password protected"
　　　　　i = i + 1
　　　　End With
　　　　Else
　　　　For Each sh In wb.Worksheets
　　　　　With sh
　　　　　　'セルの文字列に完全マッチしたいなら
　　　　　　'xlWholeを使う。部分マッチしたいならxlPartを使う。
　　　　　　'現在は、部分マッチで、ワイルドカードにしています。*
　　　　　　Set c = .UsedRange.Find(strTxt & "*", _
　　　　　　LookIn:=xlValues, _
　　　　　　LookAt:=xlWhole, _
　　　　　　SearchOrder:=xlByRows, _
　　　　　　SearchDirection:=xlNext)
　　　　　　
　　　　　　If Not c Is Nothing Then
　　　　　　　FirstAddress = c.Address
　　　　　　　Do
　　　　　　　　With mySh
　　　　　　　　　.Cells(i, "A").Value = Fname
　　　　　　　　　.Cells(i, "B").Value = sh.Name
　　　　　　　　　.Cells(i, "C").Value = c.Value
　　　　　　　　End With
　　　　　　　　i = i + 1
　　　　　　　　Set c = sh.UsedRange.FindNext(c)
　　　　　　　Loop While Not c Is Nothing And c.Address <> FirstAddress
　　　　　　End If
　　　　　End With
　　　　Next sh
　　　End If
　　　DoEvents
　　　wb.Close False
　　　Set wb = Nothing
　　　Beep
　　End If
　　Fname = Dir
　Loop
　Application.ScreenUpdating = True
　mySh.Cells.EntireColumn.AutoFit
　Exit Sub
errHandler: '*
　If Err.Number = 1004 Then
　　Application.DisplayAlerts = False
　　On Error Resume Next
　　Set wb = Workbooks.Open(myFolder & Fname, , Password:=MPSWD, WriteResPassword:=MPSWD)
　　On Error GoTo 0
　　Application.DisplayAlerts = True
　　Resume Next
　End If
End Sub

この回答へのお礼

こんにちは
すごくていねいな回答をありがとうございます
そして手直しまでありがとうございます
まだ行全体を抽出するところまではできておりませんが、もう少し自分でも理解しないとだめだなと思いました
特に基礎部分ですね、反省しきりです

恥ずかしながらマクロや関数は殆どわからず、調べながらですが、意味もあまり理解せずに書いておりましたので
至らない点がたくさんあって申し訳ありません
リンク貼っていただいたEXCEL大辞典も実は見てみたのですがちんぷんかんぷんで…
今回は急ぎであまり勉強する時間がなかったのですが、これを機会にきちんと理解できるように勉強しようと思います

どうもありがとうございました

お礼日時：2017/03/23 13:16

No.5 回答者： WindFaller 回答日時： 2017/03/23 22:53

返事、ありがとうございます。

少し、最初コードを見た時に、切り分けるべきかどうか、迷いました。少し、コードが長すぎるようです。

ふつうは、作業のグループによって、プロシージャを別けるのです。
ここの作業では、２つか３つに分けます。

・ファイルの検索
・（ファイルのチェック）
・ファイルを開けて、その中身を検索する。見つけたら、その記録を取る－ブックを閉じる。

私は、そのファイルのパスワード・チェックが、ネックになってしまいました。パスワードはわかっているという前提で進めないと途中で止まってしまうのです。

パスワード付きか、そうでないかは、いくつかの方法で調べることは可能です。

>リンク貼っていただいたEXCEL大辞典も実は見てみたのですがちんぷんかんぷんで…
そうでしたか。最近は、Excelの『コーディング規約』が言われるようになりました。VBAできっちり守ったところであまり意味がないようなものですが、間違いが減りますね。

http://qiita.com/mima_ita/items/8b0eec3b5a81f168 …

http://blog.goo.ne.jp/pianyi/e/8945568a7ad880544 …
（この内容は、ざっくばらんで興味深いです）

後は、インデンターがあれば、きれいにコードを書けるようになります。
https://www.add-ins.com/macro-products-for-Micro …

本当は、プロシージャ名の命名法というのがあったりするのですが、今回、
Sub SeartchingWordsPrc()　綴を間違えてしまいました。（^^;
正しくは、Sub SearchingWordsPrc() です。

dokurocat様も、きっとすぐにベテランの域に入ってしまい、こんな話もできなくなってしまうでしょうけれども、私などは、いつまで経っても基本的なところから抜け出さないでいます。

この回答へのお礼

こんばんは
すごくわかりやすいリンクをありがとうございます(*´∀｀*)
二つ目はやっちゃいけないことなど書いてあって、とても助かります
今回は急にマクロ組んでくれと言われて慌てていたので、こうやってちゃんと最初から学ばないと
本当にできるものもできないなぁ、と嫌と言うほどわかりました
このコードは実は海外のサイトからひっぱってきたもので、それを独学で直したりしたので
余計におかしなことになっているのだと思います

いえ、本当に色々と助かりますし、まだ初心者から当分抜け出せないと思います
ご丁寧に何度も回答ありがとうございます
個人的に先生になっていただきたいほどです
でもいつまでもお手を煩わせてはいけないので、これで締め切らせていただきますね
何から何まで、本当にありがとうございました！

お礼日時：2017/03/24 00:09

No.3 回答者： yokomaya 回答日時： 2017/03/22 23:46

＞これをどこに挿入すればいいですか？

は？


＞検索した言葉のセルだけは抽出できたのですが、
＞行全体までは抽出できませんでした。

出来てるんじゃないの？
出来てる前提の答えでした。

なんだこれ？
Dir終わってないのにFindしてるじゃん。

いやいや、全部並んでから検索しませう。
文字並べてる途中で検索って変だと思わないの？

Set c =
で始まるところが見つけるところなんで
No1とかNo2を使って.copyでコピーしといて
後で貼り付けます。
貼り付けは、今は代入してるけど
WS.Range("A4").Offset(a, 0).Value = Value
のところに
WS.Range("A4").Offset(a, 0).PasteSpetial
みたいな感じ？勿論残りの代入は要りません。

ただその前にまずは、今述べた通り
DirとFindは別ループにしないと
完全に無駄です。

この回答へのお礼

これで抽出できてたのでできてると思っていました。
DirとFindを別にするんですね。
わかりましたやってみます。ありがとうございました。

お礼日時：2017/03/23 00:08

No.2 回答者： yokomaya 回答日時： 2017/03/22 21:28

AからC列だけなら

Range(Cells(c.row,"A"),Cells(c.row,"C"))
ですね。

この回答へのお礼

ありがとうございます、恐縮なのですが、これをどこに挿入すればいいですか？

お礼日時：2017/03/22 22:43

No.1 回答者： yokomaya 回答日時： 2017/03/22 21:25

見つけた

Range.EntireRow
で行全体です。
この場合
ｃ.EntireRow
かな。
当然ながらA列にしか貼り付け出来ません。