検索値に一致するデータ行の抽出方法（エクセル）

質問

例えば・・・

↓データ
＿ＡＢＣＤＥ
１あカａ1122
２あキｂ1223
３いクｃ1324
４うケｄ1425
５うコｅ1526

のようなデータがあったとして、別のシートの任意のセル（例えばＡ１）に「あ」と入力し、Ｃ列に「カ」を入力することでＣ列以降のデータをＤ列以降に並べたいのですが・・・

結果↓

＿ＡＢＣＤＥ
１う←任意のセル：データシートのＡ列の検索値
２
３＿＿＊項目＊
４＿＿ケｄ1425
５＿＿コｅ1526
＿＿＿↑
＿＿＿データシートのＢ列を検索する値を入力するＣ列　　　

＊データの行数は5000は軽くあります。
＊データシートは、受け取る側のシートとは別のファイルにしたい。
＊受け取る側は、1～100行になります。（ファイルによります）
＊受け取る側のファイルは、100ファイルぐらいになります。
＊いずれのファイルも列数は2,30列程度です。
＊格納するフォルダは同じです。
＊できればフォルダ毎別のＰＣに持っていっても作業できるようにしたい。

環境：構築していくマシンは、Ｗｉｎｄｏｗｓ２０００Ｐｒｏ，Ｅｘｃｅｌ２０００です。
（実際の抽出作業もこれがメインのＰＣですが、Ｗｉｎ９５、９８，Ｅｘｃｅｌ９７、２０００でも抽出作業ができれば嬉しいです。）

回答No.3

nishi6 · ベストアンサー

1) B1に表示
2) ALL(半角)　またはＡＬＬ(全角)　で全項目を抽出。
3) クリアした
4) B1が未入力の場合、1回目と解釈。項目を表示した。
5) 6)とからめて、受け取るシートのH列からSUMをセット。10000行を集計する算式。
6) データシートはG列から12列、月次データ。受け取るシートには1列ずれて、
　 H列から5列、月次データを逆順に表示。

データシートの1行目は項目名としています。
補足もこれくらいにしましょう。意図したことを行っているかどうかも分かりません。
ご参考に。

ThisWorkbookに貼り付け
↓
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
　'単一セルを操作、C列に入力
　If Not (Target.Count = 1 And Target.Column = 3) Then Exit Sub

　Set wsData = Workbooks("srcBook1.xls").Worksheets("Sheet1")

　Dim wYMD As Date　　　　　'入力した日付
　Dim c As Integer, c2 As Integer '列カウンタ

　Dim strA1 As String　　　　'全指定用、A列の値
　Dim strB_old As String　　 '全指定用、B列の値
　Dim r As Long　　　　　　　'全指定用、行カウンタ

　'入力した日付から項目列を決める
　wYMD = Range("D1")
　For c = 1 To 5
　　'項目名と同じ日付を作る（データシートの１行目のG列以降は日付形式とした）
　　hdYMD(c) = DateSerial(Year(wYMD), Month(wYMD) + c - 1, 1)
　Next
　'書き出す列を決める
　On Error Resume Next
　For c2 = 1 To 5
　　wCol(c2) = 0
　　For c = wsData.Range("IV1").End(xlToLeft).Column To 1 Step -1
　　　If hdYMD(c2) = wsData.Cells(1, c) Then
　　　　If c >= 7 Then 'G列より右なら
　　　　　wCol(c2) = c
　　　　End If
　　　　Exit For
　　　End If
　　Next
　Next
　On Error GoTo 0

　'データを抽出する
　Application.EnableEvents = False
　If StrConv(Target.Text, vbNarrow) <> "ALL" Then
　　'単独指定
　　Data_Pick_Sub Target
　Else
　　'全指定(A、B列はソートされていることが条件)
　　strA1 = Range("A1")
　　Target.Select
　　For r = 2 To wsData.Range("A65536").End(xlUp).Row
　　　If wsData.Cells(r, 1) = strA1 Then
　　　　If wsData.Cells(r, 2) <> strB_old Then
　　　　　'今までに処理していない文字なら入力の変わりに書き込む
　　　　　ActiveCell = wsData.Cells(r, 2)
　　　　　'抽出処理を行う
　　　　　Data_Pick_Sub ActiveCell

　　　　　strB_old = wsData.Cells(r, 2) '今処理した文字列
　　　　End If
　　　End If
　　Next
　End If
　Application.EnableEvents = True
End Sub

標準モジュールに貼り付け
↓
Public wsData As Worksheet 'データシート
Public wCol(5) As Integer '日付に対応して書き出す列番号
Public hdYMD(5) As Date '項目名の日付

'データを抽出する
Sub Data_Pick_Sub(schRg As Range)
　Dim rw As Long '行数
　Dim cLstCol As Integer 'コピー元のセル範囲の最後の列
　Dim cRow As Integer 'コピー先の行番号
　Dim strA As String, strC As String 'A列の値、C列の値

　Dim HD As Integer, wHD As Integer '表題カウンタ
　Dim TopAdr As String, BotAdr As String 'Sum用の開始、最終アドレス

　strC = schRg.Text
　strA = schRg.Offset(0, -2).End(xlUp).Text

　With wsData
　　For rw = 1 To .Range("A65536").End(xlUp).Row
　　　If .Cells(rw, 1) = strA Then
　　　　If .Cells(rw, 2) = strC Then
　　　　　cLstCol = 11 '元のデータの範囲を決める
　　　　　wHD = 0
　　　　　For HD = 2 To cLstCol 'コピー実行
　　　　　　If schRg.Offset(0, HD - 2).Column > 7 Then 'G列(7がGのこと)以降
　　　　　　　wHD = wHD + 1
　　　　　　　If wCol(wHD) > 0 Then
　　　　　　　　schRg.Offset(cRow, HD - 2) = wsData.Cells(rw, wCol(wHD))
　　　　　　　End If
　　　　　　Else
　　　　　　　schRg.Offset(cRow, HD - 2) = wsData.Cells(rw, HD)
　　　　　　End If
　　　　　Next

　　　　　'*** B1が未登録の時、最初の処理とする ***
　　　　　If Range("B1") = "" Then
　　　　　　Range("B1") = .Cells(rw, 2)
　　　　　　With schRg
　　　　　　　wHD = 0
　　　　　　　For HD = 2 To cLstCol '項目名を書く
　　　　　　　　If .Offset(0, HD - 2).Column > 7 Then 'G列(7がGのこと)以降
　　　　　　　　　wHD = wHD + 1
　　　　　　　　　.Offset(-1, HD - 2) = Format(hdYMD(wHD), "yyyy/mm/dd")
　　　　　　　　Else
　　　　　　　　　.Offset(-1, HD - 2) = wsData.Cells(1, HD)
　　　　　　　　End If
　　　　　　　Next
　　　　　　　For HD = 2 To cLstCol '合計の算式を書く
　　　　　　　　TopAdr = .Offset(0, HD - 2).Address(0, 0)
　　　　　　　　BotAdr = .Offset(10000, HD - 2).Address(0, 0)
　　　　　　　　If .Offset(0, HD - 2).Column > 7 Then 'G列(7がGのこと)以降
　　　　　　　　　.Offset(-2, HD - 2).Formula = "=SUM(" & TopAdr & ":" & BotAdr & ")"
　　　　　　　　End If
　　　　　　　Next
　　　　　　End With
　　　　　End If

　　　　　cRow = cRow + 1 '複数見つかったら次の行へ
　　　　End If
　　　End If
　　Next
　End With
　Application.CutCopyMode = False 'コピー内容を空にする
　schRg.Offset(cRow, 0).Select 'C列に復帰
End Sub

お礼

ｎｉｓｈｉ６さん！ありがとうございます。お返事が遅れてすみません。
実は、なかなか時間に余裕がなく、現在作業中断の状態です。
コードもまだ実際のもにに落とし込めていません。いづれにしろ今月か来月には仕上げていきたいので、教えていただいたコードを参考に、勉強しながらやっていきます。
すぐすぐに結果が書けそうにないので、取り急ぎお礼申し上げます。ありがとうございました。
今後、部分的に質問することがあると思いますが、その際にはよろしくお願いいたします。

回答No.2

nishi6

＞Data_Pick_Subでとまります。何故でしょうか？
失礼しました。回答に１行抜けていました。多分この影響です。

Dim wsData As Worksheet　'←この１行を追加して下さい。

Sub Data_Pick_Sub(schRg As Range)

Excel2000 で確認しました。

＞それと、データシートの検索列を指定させている部分を教えてください。

標準モジュールに貼り付けた部分で
　If wsData.Cells(rw, 1) = strA Then
　　この Cells(rw, 1) の1がＡ列を表します。

　　If wsData.Cells(rw, 2) = strC Then
　　　この Cells(rw, 2) の2がＢ列を表します。

　　　wsData.Range(wsData.Cells(rw, 3), wsData.Cells(rw, copyLastCol)).Copy
　　　　この Cells(rw, 3) の3がＣ列を表します。
　　　　一番右の列は計算しています。列IVから左に動いて登録された列を探しています。

質問にあるままにしているつもりです。
Cells(行,列)の引数『列』は　列A,B,C,D,E,F・・・に対し、1,2,3,4,5,6・・・　となります。

//////////////////////////////////////
　ダメ押しで説明を追記しておきます。
//////////////////////////////////////

'***ThisWorkbook***
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
　　'受け取る側のシートに入力された時、それが単一セル(Target.Count=1)で
　　'Ｃ列(Target.Column=3)に入力されたら、Targetを引数にしてData_Pick_Subに分岐
　　If Target.Count = 1 Then '単一セルを操作
　　　　If Target.Column = 3 Then 'C列に入力
　　　　　　Data_Pick_Sub Target
　　　　End If
　　End If
End Sub

'***標準モジュール***
'変数を宣言
Dim wsData As Worksheet

Sub Data_Pick_Sub(schRg As Range)
　　'変数wsDataにデータシートを定義
　　Set wsData = Workbooks("srcBook1.xls").Worksheets("Sheet1")

　　Dim rw As Long '行数
　　Dim copyLastCol As Integer 'コピー元のセル範囲の最後の列
　　Dim copyRow As Integer 'コピー先の行番号
　　Dim strA As String 'A列の値
　　Dim strC As String 'C列の値

　　'strCが受け取る側のシートのＣ列に入力した値(schRgが入力したセル)
　　strC = schRg.Text
　　'strAが受け取る側のシートのＡ列に入力した値
　　'Ｃ列に入力されたら探すようにしてあるため、ここでＡ列の入力値を探している
　　'schRgから.Offset(0, -2)で左に2つ動き、.End(xlUp)で上方向に登録されたセルを探している
　　strA = schRg.Offset(0, -2).End(xlUp).Text

　　'wsData.Range("A65536").End(xlUp).Rowでデータシートのデータ数を求めている
　　For rw = 1 To wsData.Range("A65536").End(xlUp).Row
　　　　'For Next でＡ、Ｃ列を調べる
　　　　'データシートのＡ、Ｂ列の値と、受け取る側のシートのＡ、Ｃ列を照合する。
　　　　If wsData.Cells(rw, 1) = strA Then
　　　　　　If wsData.Cells(rw, 2) = strC Then
　　　　　　　　'一致したデータが見つかったら、データシートの複写範囲を決める
　　　　　　　　'列方向の最後が不明なので右方向から探している
　　　　　　　　copyLastCol = wsData.Range("IV" & rw).End(xlToLeft).Column
　　　　　　　　'コピー実行
　　　　　　　　'見つかった行の、３列目から一番右の列までをコピー
　　　　　　　　wsData.Range(wsData.Cells(rw, 3), wsData.Cells(rw, copyLastCol)).Copy
　　　　　　　　'受け取る側のシートのＣ列の右のセルに貼り付ける
　　　　　　　　schRg.Offset(copyRow, 1).Select: ActiveSheet.Paste
　　　　　　　　'複数見つかったら次の行へ貼り付けるためカウンタを進める
　　　　　　　　copyRow = copyRow + 1
　　　　　　End If
　　　　End If
　　Next
　　'次の入力を待つ
　　schRg.Offset(copyRow, 0).Select 'C列に復帰
End Sub

うまく動けばいいですが。

補足

ご丁寧にありがとうございます。うまく動きました！！大変勉強になります！感謝です！

付加機能でいくつかお願いします。

１）受け取る側とシートのＡ１の検索値のデータシートのＢ列の値（文字列）を受け取るシートのＢ１に表示する。
　　＊データシートには検索結果は複数存在しますが、受け取るシートのＢ１に１つだけ表示させたい。

２）Ａ１とＣ列に検索値を入れますが、Ａ１に該当するものすべてを抽出したい場合の方法はありませんでしょうか？
　　　　例えば、Ｃ列に"ＡＬＬ"を入力するなど・・・
　　　＊９９９９９９９の数値または、文字は１００％ありえないので使用できます。

３）Ｃ列へ入力後エンターを押した後、コピーしてきますが、次の行で誤ってエンターすると最後にコピーしてきた列を貼り付けてしまいます。できれば回避したいのですが・・・

４）データの項目をコピーしたい。項目は、日付で毎月変わっていきますので、その都度範囲指定して項目を受け取ったほうがいいのですが、一応自分でコピー＆ペーストのコードを記述してみましたが、エンターでプログラムが実行される度にコピペをしてしまいます。Ｃ列の検索値を入力後のエンターをした場合のはじめの１回のときだけコピペを実行してくれるといいのですが・・・どこの部分にどのように記述すればよいのでしょうか？

５）受け取るシートに抽出（コピー）してきたデータの、Ｇ列以降の各列の５行目
（Ｇ列と５行目は任意で、とりあえず今回の例として・・・）から最終行の縦合計を求め、４行目は項目を置いたとして、３行目の各列にその合計値を表示させたいのですが・・・

６）これは、ちょっと贅沢でやっかいなことかもしれませんが、できれば・・・
今のところ、別のシートからＭＡＴＣＨ関数で抽出しようと思って途中までできていますが、重たくなってきたので、一気にできればともおもって（＾＾; ） ・・・質問します。できればで良いです。

例えば・・・
　データシートのＧ列以降の項目（１行目）にはＧ列を基点とし当月から過去１年間の月毎の日付（月毎でＧ列が２００２／５／１で、以降Ｈ列が２００２／４／１　・・・・・これは当月を基点とし毎月変わっていきます）になっています。

受け取るシートの任意のセル、例えば"Ｄ１"に「２００２／０３／１６」などの任意の日付を入力することで入力された月から未来へ５ヶ月を計算（計算後は各月の１日）しデータシートの列（２００２／３／１～２００２／７／１）をコピーしてくるようにしたい。この例の場合は、データシートには、６月と７月のデータはないので、２００２／３／１～２００２／５／１までの該当データを抽出し、２００２／６／１～２００２／７／１までは項目のみでデータは空白になる。（この例の場合Ｄ１に入力した日付が２００２／３／？？だったら２００２／３／１～２００２／７／１までの該当データになる）

説明が下手くそですみません。何卒よろしくお願いいたします。

回答No.1

nishi6

今、データシートは、ブック名『srcBook1.xls』、シート名『Sheet1』としてあります。
『Set wsData = 』の行ですので、ご自分の環境に合うように修正して下さい。
このマクロをセットしたBook（受け取る側）と、データシートのブックを起動して実行します。
受け取る側ではどのシートでも実行できます。

受け取る側のシートでは、
　（１）Ａ列にデータシートのＡ列検索用入力
　（２）Ｃ列にデータシートのＢ列検索用入力
　（３）（１）の行番号＜（２）の行番号
が条件です。（１）、（２）に一致すれば見つかった行（複数行でも）を出力します。
（１）をそのままにして、（２）のみ変更していく事ができます。こういうことがしたかった？

ThisWorkbookに貼り付け
↓
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
　　If Target.Count = 1 Then　　　　　 '単一セルを操作
　　　　If Target.Column = 3 Then　　　'C列に入力
　　　　　　Data_Pick_Sub Target
　　　　End If
　　End If
End Sub

標準モジュールに貼り付け
↓
'データを抽出する
Sub Data_Pick_Sub(schRg As Range)
　　Set wsData = Workbooks("srcBook1.xls").Worksheets("Sheet1")

　　Dim rw As Long　　　　　　　　'行数
　　Dim copyLastCol As Integer　　'コピー元のセル範囲の最後の列
　　Dim copyRow As Integer　　　　'コピー先の行番号
　　Dim strA As String　　　　　　'A列の値
　　Dim strC As String　　　　　　'C列の値

　　strC = schRg.Text
　　strA = schRg.Offset(0, -2).End(xlUp).Text

　　For rw = 1 To wsData.Range("A65536").End(xlUp).Row
　　　　If wsData.Cells(rw, 1) = strA Then
　　　　　　If wsData.Cells(rw, 2) = strC Then
　　　　　　　　'元のデータの範囲を決める
　　　　　　　　copyLastCol = wsData.Range("IV" & rw).End(xlToLeft).Column
　　　　　　　　'コピー実行
　　　　　　　　wsData.Range(wsData.Cells(rw, 3), wsData.Cells(rw, copyLastCol)).Copy
　　　　　　　　schRg.Offset(copyRow, 1).Select: ActiveSheet.Paste
　　　　　　　　'複数見つかったら次の行へ
　　　　　　　　copyRow = copyRow + 1
　　　　　　End If
　　　　End If
　　Next
　　schRg.Offset(copyRow, 0).Select 'C列に復帰
End Sub

補足

ｎｉｓｈｉ６さん！ありがとうございます。お久しぶりです。以前は、かなりお世話になりました。その節はどうもありがとうございました。
またお世話になりますが、よろしくお願いします。

＞（１）をそのままにして、（２）のみ変更していく事ができます。こういうことがしたかった？

そのとおりです。（２）が複数行です。

ThisWorkbookに貼り付けた、
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range) に黄色マーク。

Data_Pick_Subでとまります。何故でしょうか？

それと、データシートの検索列を指定させている部分を教えてください。

よろしくお願いします。