エクセルで複数文字列を一括検索してマクロで表示。

質問

件名どおりなのですが、エクセルで７０００程度の文字列から２０程度を
マクロで一括検索して別のセルかシートに表示させたいのです。

参考にした作業は以下の回答例。
http://okwave.jp/qa/q4859029.html

＝＝以下、コピペ＝＝＝

No.2

回答日時：2009/04/07 10:13
.
複雑ではないマクロはどうでしょう？
A1セルからA50セルまでの各セルにそれぞれ検索したい文字があるとします。
検索したい範囲を選択した上で下記のマクロを実行してみてください。

Sub 連続検索()
For Each r In Range("A1:A50") '指定の各検索文字につき
Set c = Selection.Find(What:=r.Value, LookAt:=xlPart) '選択範囲を検索
If Not c Is Nothing Then 'あったら
fAd = c.Address 'セル番地を控える
Do '繰り返す
i = i + 1 'カウント
c.Interior.ColorIndex = 8 'セル着色
Set c = Selection.FindNext(c) '連続検索
Loop Until c.Address = fAd '一巡するまで'繰り返し
End If
Next r '次の検索文字で繰り返す
Set c = Nothing
MsgBox i & "件を発見しました。", vbInformation, " （￣ー￣）v"
End Sub

＝＝ここまで＝＝＝

上記のマクロで複数の文字列を一括検索ができますが、
この場合は「対象の文字列」を色付けするだけです。

７０００程度の文字列があると、スクロールして色の付いた文字列を探すだけでも
結構な時間がかかります。

これをベースに別のセルまたはシートに抽出した文字列をピックアップして
表示させるにはどのような追加がマクロに必要か、教えてください。

当方、エクセル２０００を使用しております。
上記のマクロは動作しています。

宜しくお願い致します。

回答No.5

eden3616 · ベストアンサー

>>上記のマクロは動作しています。
>コードに以下のような検索をする
>文字列（例として名前）だけで一括検索をかけて、
>抽出された文字列が持つ値も出したいのです。
>Ａ列には名前、Ｂ列に値があるとします。

No2～4の回答者様とは別に、
現状動作済みのコードを利用することで、動作不良のリスクを最小に留め、
操作方法があまり変わらない利点を備えるため、
提示して頂いたコードを追加・修正する路線で回答させて頂きます。

変更点は「★(4)の削除部分を一部修正」と「★(5)に1行追加」したぐらいです。
現状は範囲選択したセルの右隣のセルを値として取得し、★(2)で指定した「sname = "Sheet2"」「srng = "A1"」の右隣のセルに出力します。

以下のコードと入替えてご利用ください。

■VBAコード

Sub 連続検索()
'★(1)型宣言
Dim r As Range, c As Range
Dim i As Long, fAd As String
Dim sname As String, srng As String
Dim strow As Long, stcol As Long

'★(2)出力先のシート名と開始セル
sname = "Sheet2"
srng = "A1"

'★(3)開始行、列の取得
strow = Range(srng).Row
stcol = Range(srng).Column

'★(4)出力先の削除
With Sheets(sname)
.Range( _
.Cells(strow, stcol), _
.Cells(.Cells(Rows.Count, stcol).End(xlUp).Row, stcol + 1) _
).ClearContents
End With

For Each r In Range("A1:A50") '指定の各検索文字につき
Set c = Selection.Find(What:=r.Value, LookAt:=xlPart) '選択範囲を検索
If Not c Is Nothing Then 'あったら
fAd = c.Address 'セル番地を控える
Do '繰り返す
i = i + 1 'カウント
'★(5)一致した文字列・値を出力
Sheets(sname).Cells(strow - 1 + i, stcol).Value = c.Value
Sheets(sname).Cells(strow - 1 + i, stcol + 1).Value = c.Offset(0, 1).Value
'★(6)着色をコメントアウト
'c.Interior.ColorIndex = 8 'セル着色
Set c = Selection.FindNext(c) '連続検索
Loop Until c.Address = fAd '一巡するまで'繰り返し
End If
Next r '次の検索文字で繰り返す
Set c = Nothing
MsgBox i & "件を発見しました。", vbInformation, " （￣ー￣）v"
End Sub

お礼

無知な私にもわかりやすいご指導を誠にありがとうございます。
今回のご回答で望むべき完全な動作が得られました。

途中、検索できない、という不具合もスペースの問題で解消し、
マクロ動作もご指導頂いたように既出のマクロをベースに
手を加える方法が私には理解しやすいようでこちらを採用させて頂きました。

この度はご丁寧で理解しやすいご教授を大変感謝致します。
どうもありがとうございました。m(_ _)m

回答No.4

tom04

No.2・3です。

たびたびごめんなさい。
投稿後気になったコトがありました。
A列データは「氏名」というコトですので、もしかして姓と名の間にスペースが入っていませんか？

場合によってはスペースを入れるコトがあると思います。
スペースも半角と全角では全く別物になってしまいますので、フィルタを掛けてもヒットしません。
そこで元データに手を付けるのは好みではないのですが、
とりあえず元データ・検索データの両方を統一してみてはどうでしょうか？
日本語入力だと思いますので、全角スペースに置換してみました。

↓のコードに変更してマクロを実行してみてください。
★印のところで置換しています。

Sub Sample2()
Dim i As Long, lastRow1 As Long, lastRow2 As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
lastRow2 = wS.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
.Range("A:A").Replace what:=" ", replacement:="　", lookat:=xlPart '★　Sheet1のA列
wS.Range("D:D").Replace what:=" ", replacement:="　", lookat:=xlPart '★　Sheet2のD列
If lastRow2 > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow2, "B")).ClearContents
End If
For i = 2 To wS.Cells(Rows.Count, "D").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "D")
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow1, "B")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteAll
End If
Next i
.AutoFilterMode = False
Application.ScreenUpdating = True
End With
End Sub

今度はどうでしょうか？m(_ _)m

お礼

遅いお時間まで検討していただき誠にありがとうございます。
心より感謝しております。
せっかくのコードですから、これを参考に
同じ検索方法の２種類を保存したいと思います。
この度は温かいご指導本当に助かりました。
専門的な知識の豊かさに羨ましい限りです。
質問をして良かったなとつくづく感じます。
では、今回は大変お世話になりました。
これで失礼させていただきますね。

回答No.3

tom04

No.2です。

＞Sheet1のＡ列２行目から７２００行程度まであり、
＞それを反転させてマクロを実行しています。

すなわち範囲指定した後にマクロを実行されているのでしょうか？
前回のコードは範囲指定せず、A列最終行までの範囲をD列に入力されている順にフィルタを掛けています。
すなわち範囲指定の必要はありません。
（範囲指定しても大丈夫だと思いますが・・・）

4名くらいしか表示されないというコトはフィルタを掛けた段階でヒットするものがないのでは？
試しにD列セルを選択　→　数式バー内に表示されている名前をドラッグ＆コピー
→　A列でオートフィルタ　→　テキストフィルタ　→　「指定の値に等しい」　→　入力窓に貼り付けてフィルタを掛けてみてください。
（本来であればここで手入力なのですが、確認の意味です）

考えられる原因としてはA列データとD列データが一致していない！というコトくらいなので。

他の原因ならごめんなさいね。m(_ _)m

お礼

何度もご丁寧なご指導誠にありがとうございます。
検索する氏名は必ず存在します。
検索できない原因は、やはり無いと思っていたスペースでした。
確認方法のご教授ありがとうございます。
もちろん、補足に書いたとおり苗字と名前の
間にスペースはすべて入れていませんでした。

入っていないと思われたスペースですが、
以下のようになっていたようです。
＜例＞
ヤマダタロウ○○

上記の○○の、見た目上はスペースに見えない空白が
実はスペースが出来ていた、出来ているものがあったという事でした。

マクロコードは以前参考にした内容に手を加えたものの方が
無知な私には理解しやすいので、Ｎｏ１様を採用させて頂きました。
誠にすみません。

この度は大変理解しやすく、また大変丁寧なご指導を頂きまして
とても感謝しております。
どうもありがとうございました。m(_ _)m

回答No.2

tom04

こんばんは！
横からお邪魔します。

＞索したい文字列が持つ値も一緒に
＞別シート（Sheet2）に出したいのです。
＞Ａ列には名前、Ｂ列に値があるとします

というコトですので・・・
↓の画像のように左側が元データでSheet1とし、右側のSheet2に表示させるとします。
尚、検索したい氏名はSheet2のD2セル以降に入力済みだという前提です。
標準モジュールです。

Sub Sample1()
Dim i As Long, lastRow1 As Long, lastRow2 As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
lastRow2 = wS.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
If lastRow2 > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow2, "B")).ClearContents
End If
For i = 2 To wS.Cells(Rows.Count, "D").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "D")
If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow1, "B")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteAll
End If
Next i
.AutoFilterMode = False
Application.ScreenUpdating = True
End With
End Sub

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

補足

大変ありがとうございます。
まさしくこの作業でドンピシャです。
上手に値まで表示されています。

ただ、２０名程度一括検索しているのに、
何度行っても、４名前後しか表示されません。

名前はカタカナで入力されていて、
Sheet1のＡ列２行目から７２００行程度まであり、
それを反転させてマクロを実行しています。

検索したい名前は、テキスト（メモ帳）からコピペで
エクセルSheet2のＤ２以下に貼り付けて行っています。

まったく検索されないのなら、どこか致命的な間違いがあるのでしょうが、
数名分は表示されるのでなおさらわかりません。
スペースは入れずにスペル間違いもありません。
もちろん、Sheet1に含まれないということもありません。
（エクセル検索機能で含まれている事も確認しています。）

大変お手数をお掛けいたしますが、何か原因の心当たりが
ございましたら、どうぞよろしくお願い致します。

回答No.1

eden3616

追加したものは以下になります。
着色する機能が必要であれば、★(6)のコメントアウトを外してください（先頭の「'」を削除）。
現状は★(2)で設定している「Sheet2」のセル「A1」を先頭のセルとして
その下側に一致した文字列が出力されるようになっています。
必要に応じて変更してください。

★(1)型宣言を追加
★(2)出力先の設定
★(3)設定から開始行、列番号を取得
★(4)以前の出力結果を削除
★(5)一致した値を(2)の出力先へ出力
★(6)背景色を付ける機能をOFF

以下のVBAコードと差し換えてご利用ください。

■VBAコード

Sub 連続検索()
'★(1)型宣言
Dim r As Range, c As Range
Dim i As Long, fAd As String
Dim sname As String, srng As String
Dim strow As Long, stcol As Long

'★(2)出力先のシート名と開始セル
sname = "Sheet2"
srng = "A1"

'★(3)開始行、列の取得
strow = Range(srng).Row
stcol = Range(srng).Column

'★(4)出力先の削除
With Sheets(sname)
.Range( _
.Cells(strow, stcol), _
.Cells(.Cells(Rows.Count, stcol).End(xlUp).Row, stcol) _
).ClearContents
End With

For Each r In Range("A1:A50") '指定の各検索文字につき
Set c = Selection.Find(What:=r.Value, LookAt:=xlPart) '選択範囲を検索
If Not c Is Nothing Then 'あったら
fAd = c.Address 'セル番地を控える
Do '繰り返す
i = i + 1 'カウント
'★(5)一致した値を出力
Sheets(sname).Cells(strow - 1 + i, stcol).Value = c.Value
'★(6)着色をコメントアウト
'c.Interior.ColorIndex = 8 'セル着色
Set c = Selection.FindNext(c) '連続検索
Loop Until c.Address = fAd '一巡するまで'繰り返し
End If
Next r '次の検索文字で繰り返す
Set c = Nothing
MsgBox i & "件を発見しました。", vbInformation, " （￣ー￣）v"
End Sub

補足

ご丁寧な回答ありがとうございます。
まさに出来ました。

恐れ入りますが、ご教授されたコードに以下のような検索をする場合は
どのようにすれば宜しいでしょうか？

文字列（例として名前）だけで一括検索をかけて、
抽出された文字列が持つ値も出したいのです。

例として、

ヤマダタロウ　　５１．２
スズキイチロウ　６３．９
（以下、２０名分程度を一括検索）

などというように、検索したい文字列が持つ値も一緒に
別シート（Sheet2）に出したいのです。

Ａ列には名前、Ｂ列に値があるとします。

どうぞ宜しくお願い致します。