指定した日付の範囲内でデータを抽出したい。

Question

エクセルのVBAを勉強中なのですがコードが分からないのでアドバイスをお願いします。
やりたいことは確認シートのE２とG2に入力された日付の範囲内で出勤した日数がE3とG3で入力された日数出勤してる人だけを抽出してそのシート名を確認シートのA2からA3・A4・・・と返したいです。以下書いてみたコードです。これだと1週目と２週目に3日出勤した人は２回名前が載ることになってしまいます。２週目だけや３週目だけ○日出勤した人を抽出するにはどうしたらいいでしょうか。よろしくお願いします。
※1週間ごとに出勤した日数は計算されます。例えば、Aさんのシートの10/110/7まで欄にシフトを入力するとAさんのシートのJ9:J13の結合されたセルに勤務日数が返ります。
※第２週（10/810/14まで）のシフトを入力するとJ16:J20の結合セルに出勤日数が返ります
※Aさん以下B・C・D・・・と同じシートです。
※入力は〇週ではなく日付で行いたいです。

Sub 出勤日数()

Dim i As Long
Dim keyword As String
Dim lastrow As Long

keyword = Worksheets("確認").Cells(3, 5).Value
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "確認" Then
For 日付行1 = 9 To 36
If Worksheets(i).Cells(日付行1, 10).Value = keyword Then
Worksheets("確認").Activate
lastrow = Worksheets("確認").Cells(Rows.Count, 1).End(xlUp).row
Worksheets("確認").Cells(lastrow + 1, 1).Value = Worksheets(i).Name
End If
Next 日付行1
End If
Next i

End Sub

Answer 1

Answer 2

Option Explicit

Dim 自期 As Date
Dim 去期 As Date
Dim 日数 As Long
Dim i As Long 'シートカウント
Dim s As Long '判断日数Range("E3")
Dim 行数 As Long
Dim 行変数 As Long
Dim Rhajime As Long '初めのRow番地
Dim Rowari As Long '終わりのRow番地
Sub データ取得()
'****//指示された１週間のデータ集計します//*****************
Application.ScreenUpdating = False
Sheets("確認").Select
自期 = Cells(2, 5).Value '週の始まり
去期 = Cells(2, 7).Value '週の終わり
For i = 2 To Sheets.Count '社員名シート左から２番めから
Sheets(i).Select '左から（i)番目
行数 = Cells(Rows.Count, 2).End(xlUp).Row 'シート（i)番目の日付最終行
For 行変数 = 9 To 行数
Cells(行変数, 2).Select
If Cells(行変数, 2) = 自期 Then '日付行と自期照合(週初め)
Rhajime = 行変数 '行変数(Row番地)を変数Rhajimeに保管
Else
If Cells(行変数, 2) = 去期 Then '去期(週終わり)
Rowari = 行変数 - 1 '行変数(Row番地)を変数 Rowariに保管

          'Excel関数（CountIf)使う為１週間のセル範囲する
          Range(Cells(Rhajime, 4), Cells(Rowari, 4)).Select
          
           日数 = WorksheetFunction.CountIf(Range(Cells(Rhajime, 4), _
           Cells(Rowari, 4)), "〇")
             Cells(Rhajime, 10) = 日数
         Exit For
        End If
     End If
Next 行変数

Next i
Call データ表示 '//一か月の日数表示//
Call データ表示1 '*****//1週間の日数表示//***
Sheets("確認").Select
Application.ScreenUpdating = True
End Sub

Sub データ表示()
Dim ii As Long '
Dim n As Long '行間隔(週７日）

Sheets("確認").Select
For ii = 1 To 4 '4週間
For i = 2 To Sheets.Count
Sheets(i).Select
日数 = Cells(9 + n, 10).Value
Sheets("確認").Cells(9 + i, 2 + ii) = 日数
Sheets("確認").Cells(9 + i, 2) = Sheets(i).Name
Next i
n = n + 7 '行間隔(週７日）
Next ii
Sheets("確認").Select
End Sub
Sub データ表示1()
Dim ii As Long '
Dim n As Long '行間隔
'明細クリア******************
Sheets("確認").Select
Range("C11:F28").Select
Selection.ClearContents
Range("B11").Select
'***************************************
自期 = Cells(2, 5).Value

For i = 2 To Sheets.Count

    Sheets(i).Select
      行数 = Cells(Rows.Count, 2).End(xlUp).Row
   For 行変数 = 9 To 行数
   
         Cells(行変数, 2).Select
     If Cells(行変数, 2) = 自期 Then
            Rhajime = 行変数
            
       '***//ここで何週目のデータか判断//******
        If Rhajime = 9 Then Call 第1週目
        If Rhajime = 16 Then Call 第2週目
        If Rhajime = 23 Then Call 第3週目
        If Rhajime = 30 Then Call 第4週目
            
     End If
   Next 行変数
 Next i

End Sub
Sub 第1週目()
'//Sheets("確認")へ出力//← Sheets(i)の勤務日数***
Sheets("確認").Cells(9 + i, 3) = Cells(Rhajime, 10).Value
End Sub
Sub 第2週目()
Sheets("確認").Cells(9 + i, 4) = Cells(Rhajime, 10).Value
End Sub
Sub 第3週目()
Sheets("確認").Cells(9 + i, 5) = Cells(Rhajime, 10).Value
End Sub
Sub 第4週目()
Sheets("確認").Cells(9 + i, 6) = Cells(Rhajime, 10).Value
End Sub

Answer 3

Sub 出勤日数()

Dim i As Long
Dim keyword As String
Dim lastrow As Long
Dim Week As Long '1週間（７日）
Dim 日数 As Long

'**//月始めのデータのみ取得//*************************************
keyword = Worksheets("確認").Cells(3, 5).Value

For i = 2 To Worksheets.Count

If Worksheets(i).Name <> "確認" Then

    For 日付行1 = 1 To 4 '４週間
    
    If Worksheets(i).Cells(9 + Week, 10).Value >= keyword Then
    
          日数 = Worksheets(i).Cells(9 + Week, 10).Value
          
          MsgBox Worksheets(i).Name & Chr(10) & 日数
                    Week = Week + 7
                    

' Worksheets("確認").Activate

        lastrow = Worksheets("確認").Cells(Rows.Count, 1).End(xlUp).Row
        
        '**//シート名を表示と勤務日数//********************
        Worksheets("確認").Cells(lastrow + 1, 1).Value = Worksheets(i).Name
        Worksheets("確認").Cells(lastrow + 1, 2).Value = 日数
    
    Exit For  '見つかった週から抜ける（次のシートへ）
    
    End If
   
    Next 日付行1
End If
 Week = 0  '次のシートの１週目に入る為

Next i

End Sub

Comments

[syousuke.33]

希望に相か分かりませんがサンプルコードも
記載しました
PCの画面、左半分シート・右半分Moduleに表示して
一度Module画面の方をクリックしてからキーボードの
［F8］キーを押すとプログラムがどのような動き
するか判ります
コード長いですが、よろしく

Answer 4

いくつか不明点があります。
１．日付は全シート同じなのでしょうか。
例えば、Ａさんは9月28日～10月25日ですが、Ｂさんは9月30日～10月27日になっていることは、
あり得るのでしょうか。

２．同じ条件に一致する人が複数の場合、
確認シートのどのセルに、そのシート名を返すのでしょうか。

３．各員のシートは1週間毎に、出勤日数がまとめられており、それを参照するということですが、
例えば、9月28日～9月30日が指定された場合、10月1日から10月4日までの、出勤日数も含まれて
しまいます。
従って、開始日から終了日を指定するのではなく、第○週から第●週までを指定させてはいかがでしょうか。
（○●は１～４）

それとも、日付の指定時、9月28日～9月30日はエラーにして、9月28日～10月4日のみが正常扱いにしたいのでしょうか。

Comments

[syousuke.33]

syun0334様のソースコード実行してみましたが
無限ループが発生しました。
Book名を見ると（version)自動回復されたソースコードのようで修正前？
そこで、syun033様のコード基に勝手に変えてみましたが
月始めの１週間のデータしか読みとれませんでした
コード載せておきます