複数シートから検索文字がある列を摘出したい

質問

初心者ですのでお力お貸し下さい。

30sheet以上あるエクセルファイルから、
特定の文字(あるいは数字)が入ったセルを検索し、その特定文字が入った一列を新規sheetへ摘出したいと考えております。
各sheetには下記の様な表が作成されており、1sheetに検索文字は0だったり複数あったりします。

A B C D
1 ◯会社 123 田中 1111
2 ▫️会社 456 佐藤 2222
3 △会社 789 加藤 3333
4 ◯会社 123 田中 4444
(表示がうまくされてなかったらすみません)

上記の様な表から、123(または田中)のみを新規sheetにまとめて表示させたいです。
またsheet毎に田中があったりなかったりしますが、全てのsheetから摘出させたいです。

新規sheetは検索結果のみを表示させて、一つの表にしたいです。

エクセルは2003使用です。
説明が下手で申し訳ありませんが、関数マクロは問いませんので分かり易く教えて頂けると助かります。
よろしくお願いします。

回答No.5

keithin

＞全ての表示させたいデータが出てこなかったです・・・一部のみが表示されていました

拾うのと拾えないのがあるってことはマクロの間違いじゃなく、

１）（拾えなかった）データが間違ってる
　（田中を拾うつもりなのに「田□中」（□はスペース）など間違ったデータが記入されているとか）
２）そもそもヤリタイことが正しく説明できてない
　（123を拾うといいながら、実は123456も拾いたいと思っていたとか）

のどちらかだということです。

拾えなかったデータを見直して間違いが無いか確認してください
どうしても出来ないときは、拾いたいと思ってたのに拾えなかったデータが具体的にどういう内容なのか、正しく実際のエクセルデータの内容を挙げてご相談を投稿しなおしてください。

回答No.4

tom04

No.1・3です。

B列に「123」もしくはC列に「田中」の行すべてを表示すればよい！
という解釈でした。

ただ1行間違っていました。

＞.Range("A1").AutoFilter field:=5, Criteria1:="*123", Operator:=xlOr, Criteria2:="*田中*"
の行を
＞ .Range("A1").AutoFilter field:=5, Criteria1:="123*", Operator:=xlOr, Criteria2:="*田中"
に変更してください。
（アスタリクスの位置が違っていました）。

これでB列に「123」もしくはC列に「田中」がある行すべてが一番左側Sheetに表示されるはずです。

どうも失礼しました。m(_ _)m

回答No.3

tom04

No.1です。

＞エラーが出てしまい表示させるところまでいけず・・・

確認ですが↓のようになっているでしょうか？

（1）前回のアップしている画像は左側が表示させたいSheetでSheet見出しの一番左側に配置してある。
（2）Sheet見出しの2番目以降のSheetはすべて同じ配置で右側のようになっている。
（質問通りA～D列だけのデータである。）
（3）コードはちゃんと標準モジュールに記載しているか？

今一度上記のコトを確認してみてください。
ちゃんと条件があっていれば
Sheet見出しの一番左側Sheetに表示されると思うのですが・・・m(_ _)m

回答No.2

keithin

標準的な「探してコピーする」だけの作業です。

手順：
ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
　dim c as range
　dim c0 as string
　dim w as worksheet
　dim x as variant

’結果シートの準備
　on error goto errhandle
　worksheets("検索結果").cells.clearcontents
　worksheets("検索結果").range("A1:D1") = array("会社","記号","担当","数字")
　on error goto 0

’検索ワードの入力
　x = inputbox("検索内容")
　if x = "" then exit sub

’各シートの検索
　for each w in worksheets
　if w.name <> "検索結果" then
　　set c = w.cells.find(what:=x, lookin:=xlvalues, lookat:=xlwhole)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　c.entirerow.copy destination:=worksheets("検索結果").range("A65536").end(xlup).offset(1)
　　　　set c = w.cells.findnext(c)
　　　loop until c.address = c0
　　end if
　end if
　next
　exit sub

’結果シートの作成
errhandle:
　worksheets.add before:=worksheets(1)
　activesheet.name = "検索結果"
　resume
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＴ＋Ｆ８を押してマクロを実行する。

お礼

検索結果を表示させるところまでいったのですが、何故か検索結果に全ての表示させたいデータが出てこなかったです・・・一部のみが表示されていました。
もう少し勉強してみます、ありがとうございます！

回答No.1

tom04

こんばんは！
VBAでの一例です。

＞新規sheetにまとめて表示させたいです。
その都度新規Sheetを追加するとSheet数が増えるばかりですので、
「新規Sheet」（結果表示させたいSheet）をSheet見出しの一番左側に配置してあるという前提です。
すなわち元データはSheet見出しの左から2番目以降にあるとします。

尚、各Sheetとも↓の画像のように1行目が項目行で2行目以降にデータがあるとします。
画像では左側が結果を表示させるSheet（Sheet見出しの一番左側Sheet）とします。
↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1() 'この行から
Dim k As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets(1)
Application.ScreenUpdating = False
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D")).ClearContents
End If
For k = 2 To Worksheets.Count
With Worksheets(k)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(.Cells(2, "E"), .Cells(lastRow, "E")).Formula = "=B2&""_""&C2"
.Range("A1").AutoFilter field:=5, Criteria1:="*123", Operator:=xlOr, Criteria2:="*田中*"
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy _
Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
.AutoFilterMode = False
.Range("E:E").Clear
End With
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

※　マクロを実行するたびに「新規Sheet」の2行目以降は消去するようにしていますので
データ変更があるたびにマクロを実行しても構いません。m(_ _)m

お礼

教えて頂いた形をベースにやってみたのですが、エラーが出てしまい表示させるところまでいけず・・・もう少し勉強してみます、ありがとうございます！