時間が一致するデータの抽出

質問

Excel2010を使用しています。
大量のデータがあり、困っています。
添付画像の赤字部分を作りたいのですが、どなたかお力をお貸しいただけないでしょうか。

Sheet２_B列(開始時間)～C列(終了時間)間に、Sheet1_B列(入時間)が含まれるデータのA列(会員)を、Sheet2_D列(入場者)にカンマ区切りで入れたい(赤字部分)のですが、関数及びVBAの知識が浅いため、自分で思うように作れません。

時間はすべて数値で入っています。
Sheet1の会員の入時間は、Sheet1内でかぶることはありません。
Sheet2の開始時間、終了時間はSheet2内でかぶることがあります。

どうかよろしくお願い致します。

回答No.2

tom04 · ベストアンサー

こんばんは！

Sheet1・Sheet2とも日付（時刻）セルはシリアル値だとします。
VBAでの一例です。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1() 'この行から
Dim i As Long, k As Long, endRow As Long, str As String, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")

endRow = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow > 1 Then
Range(wS2.Cells(2, "D"), wS2.Cells(endRow, "D")).ClearContents
End If
For k = 2 To wS2.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To wS1.Cells(Rows.Count, "B").End(xlUp).Row
If wS1.Cells(i, "B") >= wS2.Cells(k, "B") And wS1.Cells(i, "B") <= wS2.Cells(k, "C") Then
str = str & wS1.Cells(i, "A") & ","
End If
Next i
If Len(str) > 1 Then
wS2.Cells(k, "D") = Left(str, Len(str) - 1)
End If
str = ""
Next k
End Sub 'この行まで

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

お礼

お教えいただき、ありがとうございます。
データ数を増やして試しましたところ、全部の会員名が入場者列に入りました。
本当に助かります。ありがとうございましたm(_ _)m。

回答No.4

kagakusuki

関数を使った方法です。
　こちらは、カンマ区切りになってはいないという点では回答No.3様の方法と同様ですが、配列式ではなく、通常の関数ですので、元データの値を入力するだけで結果が表示されます。

　まず、Sheet2のD2セルに次の関数を入力して下さい。

=IF(ISNUMBER(1/DAY($B2)/DAY($C2)),IF(COLUMNS($D:D)>COUNTIFS(Sheet1!$B:$B,">="&$B2,Sheet1!$B:$B,"<="&$C2),"",INDEX(Sheet1!$A:$A,MATCH(SMALL(Sheet1!$B:$B,COUNTIF(Sheet1!$B:$B,"<"&$B2)+COLUMNS($D:D)),Sheet1!$B:$B,0))),"")

　次に、Sheet2のD2セルをコピーして、Sheet2のD3以下に貼り付けて下さい。
　次に、Sheet2のD列全体をコピーして、Sheet2のE列以降の列に貼り付けて下さい。

　尚、この方法は、あくまで

>Sheet1の会員の入時間は、Sheet1内でかぶることはありません。

という条件が守られている場合にのみ有効な方法で、もしも、入り時間がかぶっている様な事がある場合には、正しい結果を得られなくなりますので注意して下さい。

お礼

お礼が遅くなりまして申し訳ありません。
教えていただきました式をSheet2のD2セルに入力したのですが、#Name?エラーが出てしまいました。
勉強不足のため自分で直せなくて、申し訳ありません。

たくさんの方に教えていただき、なんとか作業を進められそうです。この場をお借りして、回答者の皆様にお礼を申し上げます。
今回は、同一セル内に入場者名を…というリクエストに応えてくださったtom04さんをベストアンサーとさせていただきます。
今後ともよろしくお願い致します。
ありがとうございましたm(_ _ )m。

回答No.3

noname#204879

Ｄ列以右の複数列に入場者名(赤字部分)を入れたので、別解です。
Sheet2!D2: {=INDEX(Sheet1!$A$1:$A$10,SMALL(IF((Sheet1!$B$1:$B$10>=$B2)*(Sheet1!$B$1:$B$10<=$C2),ROW(A$1:A$10),""),COLUMN(A1)))}
(配列数式)
ただし、セル D2 に次の[条件付き書式]を施しています。
数式が　　　=ISERROR(D2)
フォント色　白

お礼

お教えいただき、ありがとうございます。
データ数を増やして試しましたところ、複数列ではありますが、全部の会員名が入りました。
今回は一つのセルにまとめて入れるという作業なのですが、今後方針が変わってセルを分ける作業になるかもしれませんので、その際に使わせていただきます。
ありがとうございましたm(_ _)m。

回答No.1

keithin

あんまり効率的じゃありませんが、手抜きせず丁寧に逐一見てった方が判りやすいと思います。

sub macro1()
　dim w1 as worksheet, w2 as worksheet
　dim r1 as long, r2 as long
　dim LastRow1 as long, LastRow2 as long

　set w1 = worksheets("Sheet1")
　set w2 = worksheets("Sheet2")
　lastrow1 = w1.range("A65536").end(xlup).row
　lastrow2 = w2.range("A65536").end(xlup).row

　for r2 = 2 to lastrow2
　　for r1 = 2 to lastrow1
　　　if w2.cells(r2, "B") <= w1.cells(r1, "B") and w1.cells(r1, "B") <= w2.cells(r2, "C") then
　　　　w2.cells(r2, "D") = w2.cells(r2, "D") & "," & w1.cells(r1, "A")
　　　end if
　　next r1
　　w2.cells(r2, "D") = mid(w2.cells(r2, "D"), 2)
　next r2
end sub

お礼

お教えいただき、ありがとうございます。
データを増やして試しましたところ、５行目まではうまく行きましたが、6行め以降は結果が表示されませんでした。
自分で直せれば…と思い"A65536"を"A105536"に変えて実行してみましたが、エラーになってしまいました。
お時間がありましたら、もう少し教えていただけると助かります。
どうぞよろしくお願い致します。