Excel VBA 検索して該当行を抽出

はじめまして、下記のように、Excelでマクロを組みたいのですが
組み方がわかりません。
ご教授願えませんでしょうか。

MS Ofiice2010　生徒数５００名ほど
シート１には生徒の生徒番号、氏名などがあります。
　　　　　A　　　　　B　　　　　C　　　　　D
１　生徒番号　　　氏名　　　備考
２　120001　　　　　田中
３　120002　　　　　山田　　試験時休み
４　T120009　　　　相田　　　転入

シート２には生徒の成績表：生徒番号、氏名、国語、算数、理科、社会
生徒番号でソートされていません。
　　　　　A　　　　　B　　　　　C　　　　　D　　　　　E　　　　　F　　　
１　生徒番号　　　氏名　　　国語　　　算数　　　理科　　　社会　　
２　120001　　　　　田中　　　80　　　　65　　　　　65　　　　　75
３　T120009　　　　相田　　　90　　　　85　　　　　80　　　　　80

シート１の生徒番号でシート２生徒番号を検索して、該当したら成績を
シート１の検索した生徒番号のD列以降にコピーしたいのですが
　　　　　A　　　　　B　　　　　C　　　　　D　　　　　E　　　　　F　　　　　G
１　生徒番号　　　氏名　　　備考　　　国語　　　算数　　　理科　　　社会
２　120001　　　　　田中　　　　　　　　　80　　　　65　　　　　65　　　　　75
３　120002　　　　　山田　　試験時休み
４
５
10　T120009　　　　相田　　　転入　　　 90　　　　85　　　　　80　　　　　80

お手数ですが、ご教授願えますでしょうか。
よろしくお願いいたします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2013/01/06 18:18

こんばんは！

関数ではダメですか？

Sheet1のD2セルに
=IF(COUNTIF(Sheet2!$A:$A,$A2),VLOOKUP($A2,Sheet2!$A:$F,COLUMN(C1),0),"")
という数式を入れオートフィルで列方向・行方向にコピー！

これで大丈夫だと思いますが・・・

※　どうしてもVBAでやりたい場合は、一例です。

Alt+F11キー　→　メニュー　→　挿入　→　「標準モジュール」を選択　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, n As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")

For i = 2 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
Set c = wS2.Columns(1).Find(what:=wS1.Cells(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
n = c.Row
wS2.Cells(n, 3).Resize(1, 4).Copy wS1.Cells(i, 4)
End If
Next i
End Sub 'この行まで

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

この回答へのお礼

ありがとうございました。
参考にさせていただきました。

お礼日時：2013/01/09 03:48

No.5 回答者： tsubuyuki 回答日時： 2013/01/07 12:47

「教授する」などと言う程の大それた内容では決してないのですが、

せめて「教示」にくらいはなるかと思いますので、数点を。
参考）http://blogs.wankuma.com/jeanne/archive/2005/11/ …


> Excelでマクロを組みたいのですが組み方がわかりません。

質問の主文はコレですね。

Ａｌｔ＋Ｆ１１　でＶＢＥが起動しますので、
やりたいこと（質問文中の処理）をコードに落として書いていけば組めます。
「ＥＸＣＥＬ マクロ」で検索すると、
この辺りを解説したサイトがジャンジャン見つかります。
「やり忘れていた冬休みの宿題」と思って、勉強なさるとよろしいのでは？と思います。
子供たちは今日あたり必死になっていることでしょうしね。



ま、「この程度」で良ければ、ＶＬＯＯＫＵＰ関数で十分です。

例えば、田中くんの国語（シート１のＤ２セル）には
　　=VLOOKUP(A2,シート２!$A:$F,3,FALSE)
田中くんの算数（シート１のＥ２セル）には
　　=VLOOKUP(A2,シート２!$A:$F,4,FALSE)
理科社会も同様に作って、下までコピーしてやると出来上がり。
シート２に該当生徒番号が無かったらエラーを返すので、
その考慮はＩＦ関数でも使えばＯＫです。

どうしてもマクロを使いたい・・
と言うか、「マクロで作れ」とおっしゃるのであれば

Sub Test()
On Error Resume Next
Sheets("シート１").Activate
　　　　For i = 2 To Sheets("シート１").Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　　For j = 1 To 4
　　　　　　　　　　　　Cells(j + 3, i) = WorksheetFunction.VLookup(Cells(1, i), Sheets("シート２").Range("A1").CurrentRegion, j + 2, False)
　　　　　　　　Next
　　　　Next
End Sub

こんな感じで提示しておきます。
ここから発展させるのも然程難しくはありません。


どちらにしても、ＶＬＯＯＫＵＰ関数が便利ですよ。
解説は、みなさんが親切に教示くださっている通りです。

この回答へのお礼

ありがとうございました。
参考にさせていただきました。

お礼日時：2013/01/09 03:48

No.4 回答者： kagakusuki 回答日時： 2013/01/07 03:21

　確認したいのですが、御質問文中のコピー後の例において、A4:C5の範囲が空欄となっていますが、これは、元々その範囲内には何も入力されていなかっただけであり、

「Sheet2に存在しない行のデータは消去しなければならない」という訳ではないと考えても宜しいのでしょうか？
　もし、そうであるのならば、次の様なマクロは如何でしょうか？

Sub Macro ()

Dim lr As Long
lr = Application.WorksheetFunction.Match("*?", Sheets("Sheet1").Columns("B:B"), -1)
Sheets.Add After:=Sheets(Sheets.Count)
With Sheets("Sheet1").Range("D1:G" & lr)
.FormulaR1C1 = _
"=IF(ISERROR(1/(VLOOKUP(RC1,Sheet2!C1:C6,COLUMNS(Sheet2!C1:C[-1]),FALSE)<>"""")),"""",VLOOKUP(RC1,Sheet2!C1:C6,COLUMNS(Sheet2!C1:C[-1]),FALSE))"
.Value = .Value
End With

End Sub

この回答へのお礼

ありがとうございました。
参考にさせていただきました。

お礼日時：2013/01/09 03:48

No.3 回答者： keithin 回答日時： 2013/01/06 21:19

ちなみにまぁ私もわざわざマクロとか使わずとも、ふつーに関数だけでやっつけた方が遥かに簡単だと思います。

ただしご相談では説明が不十分ですが、「０点を取った」のと「一部科目を休んだので点数が記入されていない」のでは全然意味が違いますので、

シート１のＤ２：
=IFERROR(IF(VLOOKUP($A2,Sheet2!$A:$F,COLUMN(C2),FALSE)="","",VLOOKUP($A2,Sheet2!$A:$F,COLUMN(C2),FALSE)),"")
右にコピー、下にコピー

のように細かく計算してやる必要があります。




＃逆に
例えば数学の試験の日に休んだので点数が無いのを単に０点としてしまっているのなら
=IFERROR(VLOOKUP($A2,Sheet2!$A:$F,COLUMN(C2),FALSE),"")
だけでいいです。

この回答へのお礼

ありがとうございました。
参考にさせていただきました。

お礼日時：2013/01/09 03:48

No.2 回答者： keithin 回答日時： 2013/01/06 20:27

データタブの統合という機能で寄せ集めさせる事ができますが、敢えてマクロでやりたいなら

sub macro1()
　worksheets("Sheet1").select
　range("D:G").clearcontents
　range("A:A").copy range("D1")
　range("D:D").consolidate sources:="Sheet2!C1:C6", function:=xlsum, toprow:=true,　 leftcolumn:=true, createlinks:=false
　range("D:E").delete shift:=xlshifttoleft
end sub

といった具合になります。
マクロを参考に（＝マクロでやらせている通りに手を動かして）、統合の機能も手で操作して練習してみて下さい。

この回答へのお礼

ありがとうございました。
参考にさせていただきました。

お礼日時：2013/01/09 03:48