エクセルVBA 複数の条件を含む対象を抜き出す。

質問

エクセルVBAについて質問です。
エクセルのバージョンは2003と2007を主に使用しています。

下記の様なデータがあるときに、部活が「野球」でかつクラブは「囲碁」に入っている生徒の学籍番号を別のシート(Sheet2)のB3から下に順にリスト化するマクロがどうしても出来なくて困っています。
find next等を使うのでは無いかと色々してみましたが上手く出来ない現状です。

<sheet1>
　　　A　　　　　　B　　　　　　C　　　　　　　D　　　　E

１　学籍番号　学年　　　　名前　　　　　部活　　　クラブ
２　2222222　　　1 　　　山田　太郎 　　野球　　　囲碁
３　9854923 　　　2　　　吉田　次郎　　　剣道　　　絵画　　
４　1111111 　　　3　　　佐藤　三郎 　　野球　　　囲碁
５　8888883 　　　1　　　米山　権蔵 　　卓球　　　囲碁

回答No.3

tom04 · ベストアンサー

こんばんは！
Sheet1のA列（学籍番号）のみをSheet2のB3セル以降に表示すれば良いわけですね？
一例です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, k As Long
Dim ws As Worksheet
Set ws = Worksheets(2)
k = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 4) = "野球" And Cells(i, 5) = "囲碁" Then
k = k + 1
ws.Cells(k, 2) = Cells(i, 1)
End If
Next i
End Sub

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

お礼

有難うございます。
無事成功しました。こんなに早く、しかも短い構文で作れるとは…
まだまだ、勉強不足でした。
本当に有難うございました。

回答No.2

mar00

Sheet2のB2に学籍番号と入力されている事が前提です。
Sub Macro1()
Set ws01 = Worksheets("Sheet1")
Set ws02 = Worksheets("Sheet2")
If ws02.Range("B3") <> "" Then
ws02.Range("B3:B" & ws02.Cells(Rows.Count, 2).End(xlUp).Row).ClearContents
End If
For i = 2 To ws01.Cells(Rows.Count, 1).End(xlUp).Row
If ws01.Range("D" & i) = "野球" And ws01.Range("E" & i) = "囲碁" Then
ws02.Range("B" & ws02.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row) = ws01.Range("A" & i)
End If
Next i
End Sub

お礼

ありがとうございます！！
さっそく試してみます！

回答No.1

goota33

今回質問された動作だとFind関数を使用しなくても実現できます。
以下にご質問された内容の動作をするソースコードを貼り付けたので試してみてください。
Sheet2のB3から下の順にリスト化されているはずです。

Public Sub test()
Dim strSerch1 As String
Dim strSerch2 As String
Dim lngLastRow As Long
Dim i As Long, j As Long

'検索する文字を以下の二つの変数に代入
strSerch1 = "野球"
strSerch2 = "囲碁"

'Sheet2にリスト化するための変数
'最初に入れるのが3行目なのでjに3を代入
j = 3

With Worksheets("Sheet1")
'.Cells(.Rows.Count, 1).End(xlUp).Rowで最後の行がどこなのか調べて
'lngLastRow変数に代入する。
'今回の場合は五行目が最後なので5が格納されます。
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = lngLastRow To 2 Step -1
'ここで四列目と五列目を同時に比較して、両方とも同じならSheet2に学籍番号を入れる処理に移る。
If .Cells(i, 4).Value = strSerch1 And .Cells(i, 5).Value = strSerch2 Then
Worksheets("Sheet2").Cells(j, 2).Value = .Cells(i, 1).Value
j = j + 1

End If

Next i

End With

End Sub

お礼

１つ１つの工程が何を意味しているのか分かりやすく、他のことにも代用できそうです！
ありがとうございました！
さっそく試してみます！