Excelで全シートから検索し列で抽出する方法

質問

現在Excel2010で作成している表をマクロで検索・抽出したいのですが、
素人のため中々思うように出来なくて困っています。

Sheet2～Sheet4まで作成した表があります。

Sheet1には検索ボタンを作成し、検索ボタンを押すと検索フォーム（ユーザーフォーム）が出てきます。

検索フォームはTextBox1とCommandButton1があります。

------ここまでは作成済みです--------

・検索フォームのTextBox1に入力した文字（半角全角英数関係なく）をCommandButton1で検索を行う。

・そしてその検索結果をSheet1の検索ボタン（セル　A～B・１～２）を避けて表からコピーして抽出（複数ある場合は複数抽出）。

・抽出内容は、検索でヒットしたセルの列全てを抽出（複数ある場合は複数の列が抽出される）。

・同列に検索した文字が２つある場合も、抽出する列は１つ。

少しややこしいかもしれませんが、上記のようなマクロを作成したいのですが私では力が足りませんでした。
わかりやすく教えていただけると嬉しいです。

回答No.2

keithin · ベストアンサー

＞検索でヒットしたセルの列全てを抽出（複数ある場合は複数の列が抽出される）。

言わずもがなですが、「列」と「行」を言い間違えてはいませんね？

各シートごとに、検索とヒットしたセルをまとめて確保、一気にコピーする事でダブりを防止します。
private sub CommandButton1_Click()
　dim i as long
　dim h as range
　dim res as range
　dim target as range
　dim c0 as string

’１枚目シートの事前掃除
　with worksheets(1)
　.range(.range("C1"), .cells(1, .columns.count)).entirecolumn.delete shift:=xlshifttoleft
　end with
　activeworkbook.save
　set target = worksheets(1).range("C1")

　for i = 2 to 4　’２枚目から４枚目のシートを対象に
　　set res = nothing

　’検索開始
　　set h = worksheets(i).cells.find(what:=me.textbox1, lookin:=xlvalues, lookat:=xlwhole, matchcase:=false, matchbyte:=false)
　　if not h is nothing then　’もし有れば
　　　c0 = h.address
　　　set res = h.entirecolumn
　　　do
　　　　set h = worksheets(i).cells.findnext(h)
　　　　set res = union(res, h.entirecolumn)
　　　loop until h.address = c0　’シート内の検索終了

　　’コピーと次の貼り付け先の調査
　　　res.copy target
　　　set target = worksheets(1).cells.specialcells(xlcelltypelastcell).offset(0, 1).end(xlup)
　　end if
　next i
end sub

＃補足
あなたの各シートの「貼り付け先はどうなっているのか」「どんな内容がコピーされるのか」といった具体的に目に見える様子の情報が何もないので、「貼り付け先を掃除する」とか「どこに貼り付けたらいいのか」とかの情報の採取のため、大変回りくどい手管を弄しています。

たとえば「全シートとも１行目がきっちり埋まっている」といった、少しでも手掛かりになりそうな目に見える情報があれば、もうちょっと簡単なマクロにする事もできました。

お礼

説明不足な点は補足させていただきました（質問まで付属してしまっていますが；）
解説付のマクロだったので、とてもわかりやすかったです。
動作も全く問題ありませんでした。
本当にありがとうございました。

補足

説明不足で申し訳ありません。

・列と行は言い間違えてません、大丈夫です。

・貼り付け先のSheet1には検索ボタン以外の情報はありません。
　Sheet1のC1から抽出内容が貼付される現在の形で問題ありま　せん。

・貼り付け先の掃除はすっかり忘れていて全く頭にありませんでした。
　マクロに含めていただいて、ありがたかったです。

・内容については具体的には言えませんが、文字・数字・画像が列に並んで表示されている形です。
（抽象的な言い方で大変申し訳ないです・・・）

・全シート、１行目はきっちりと埋まっています。

質問なのですが・・・
画像も使用しているため、掃除の際に画像だけ残ってしまいます。
画像までオールクリアする方法もあるのでしょうか？
また、現在はセル結合を使用していませんが、隣列と部分的にセルの結合を行った場合、両列同時に検索・抽出することは可能なのでしょうか？

回答No.3

keithin

＞画像

それは想定外でしたが、あなたの言ってる「画像」と、シートの左上に置いてある「ボタン」などの区別がちゃんと付いているか心配します。

きちんと文字通り使い分けが理解できているのでしたら、掃除ブロックに
activesheet.pictures.delete
と一行追記します。

言わずもがなですがボタンにも画像を使っていたら当然一緒に消しちゃいますし、そもそも「画像」じゃなく実は別のモノが置かれてたら、当然これではダメです。

＞部分的にセルの結合

説明があいまいですが、「部分的に」とは「Ａ列やＣ列には結合セルは無いけど、Ｄ列とＥ列は上から下まで隣同士セル結合している」という意味で、「ある列の途中で結合しているセルもある」という事じゃないとします。

変更前：
set res = union(res, h.entirecolumn)

変更後：
set res = union(res, h.mergearea.entirecolumn)

セル結合していないシートで変更後のマクロを使っても問題ありません。

お礼

やりたいことが全て出来るようになりました。
本当にありがとうございました。

回答No.1

tom04

こんばんは！
外しているかもしれませんが・・・

たたき台としてです。

Private Sub CommandButton1_Click()
Dim k As Long, j As Long, cnt As Long
Dim wS As Worksheet
Dim str
str = TextBox1.Value

j = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
If j > 2 Then
Range(Worksheets(1).Columns(3), Worksheets(1).Columns(j)).ClearContents
End If
cnt = 2
For k = 2 To Worksheets.Count
Set wS = Worksheets(k)
For j = 1 To wS.Cells(1, Columns.Count).End(xlToLeft).Column
If TextBox1 = "" Then
MsgBox "検索データを入力してください。", vbExclamation
TextBox1.SetFocus
Exit Sub
Else
If WorksheetFunction.CountIf(wS.Columns(j), str) Then
cnt = cnt + 1
wS.Columns(j).Copy Worksheets(1).Columns(cnt)
End If
End If
Next j
Next k
End Sub

※　条件としてSheet2以降の表は1行目に項目など何らかのデータが入っているという前提です。
（1行目で各Sheetの最終列を取得しているため）

こんな感じではどうでしょうか？m(_ _)m

お礼

説明不足な点も多く申し訳ありません。
検索・抽出と望む内容で実行することが出来ました。
ありがとうございました。