Option Explicit
 
Public Sub 滞在人数集計()
    Dim ws1 As Worksheet    '滞在予定
    Dim ws2 As Worksheet    '集計結果
    Dim lastRow As Long
    Dim row1 As Long        '滞在予定の行番号
    Dim row2 As Long        '集計結果の行番号
    Dim start_date As Date  '集計開始日
    Dim end_date As Date    '集計終了日
    Dim sdate As Date       '滞在者の滞在開始日
    Dim edate As Date       '滞在者の滞在終了日
    Dim wdate As Date
    Set ws1 = Worksheets("滞在予定")
    Set ws2 = Worksheets("集計結果")
    lastRow = ws1.Cells(Rows.count, "B").End(xlUp).Row      'B列最終行取得
    If lastRow < 3 Then
        MsgBox ("滞在者なし")
        Exit Sub
    End If
    '集計開始日と集計終了日を決定する（前泊の文字列チェック含む）
    start_date = DateSerial(2100, 1, 1)
    end_date = DateSerial(2000, 1, 1)
    For row1 = 3 To lastRow
        '前泊の文字チェック
        If ws1.Cells(row1, "D").Value <> "" And ws1.Cells(row1, "D").Value <> "前泊" Then
            Call err_proc(ws1, ws1.Cells(row1, "D"), "前泊以外の文字")
        End If
        '出発日チェック
        If IsDate(ws1.Cells(row1, "E").Value) = False Then
            Call err_proc(ws1, ws1.Cells(row1, "E"), "日付不正")
        End If
        '帰宅日チェック
        If IsDate(ws1.Cells(row1, "F").Value) = False Then
            Call err_proc(ws1, ws1.Cells(row1, "F"), "日付不正")
        End If
        '出発日<帰宅日であることのチェック
        If ws1.Cells(row1, "E").Value >= ws1.Cells(row1, "F").Value Then
            Call err_proc(ws1, ws1.Cells(row1, "F"), "日付順序不正")
        End If
        '出発日がstart_dateより前ならstart_dateを更新
        If ws1.Cells(row1, "E").Value < start_date Then
            start_date = ws1.Cells(row1, "E").Value
        End If
        '帰宅日がend_dateより後ならend_dateを更新
        If ws1.Cells(row1, "F").Value > end_date Then
            end_date = ws1.Cells(row1, "F").Value
        End If
    Next
    '集計結果クリア
    ws2.Cells.ClearContents
    ws2.Cells(1, "A").Value = "日付"
    ws2.Cells(1, "B").Value = "人数"
    '集計開始日～集計終了日設定
    row2 = 2
    For wdate = start_date To end_date
        ws2.Cells(row2, "A").Value = wdate
        row2 = row2 + 1
    Next
    '滞在者の滞在期間を設定
    For row1 = 3 To lastRow
        sdate = ws1.Cells(row1, "E").Value
        edate = ws1.Cells(row1, "F").Value
        '前泊なら翌日からカウントする
        If ws1.Cells(row1, "D").Value = "前泊" Then
            sdate = sdate + 1
        End If
        '滞在開始日～滞在終了日まで繰り返す
        For wdate = sdate To edate
            '集計結果の行番号を算出する
            row2 = wdate - start_date + 2
            '算出した行に１加算する
            ws2.Cells(row2, "B").Value = ws2.Cells(row2, "B").Value + 1
        Next
    Next
    MsgBox ("完了")
End Sub
'エラー処理
Private Sub err_proc(ByRef ws As Worksheet, ByRef rg As Range, ByVal msg As String)
    ws.Activate
    rg.Select
    MsgBox (msg)
    End
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOa7nuWcqOS6uuaVsOmbhuioiCgpCiAgICBEaW0gd3MxIEFzIFdvcmtzaGVldCAgICAn5rue5Zyo5LqI5a6aCiAgICBEaW0gd3MyIEFzIFdvcmtzaGVldCAgICAn6ZuG6KiI57WQ5p6cCiAgICBEaW0gbGFzdFJvdyBBcyBMb25nCiAgICBEaW0gcm93MSBBcyBMb25nICAgICAgICAn5rue5Zyo5LqI5a6a44Gu6KGM55Wq5Y+3CiAgICBEaW0gcm93MiBBcyBMb25nICAgICAgICAn6ZuG6KiI57WQ5p6c44Gu6KGM55Wq5Y+3CiAgICBEaW0gc3RhcnRfZGF0ZSBBcyBEYXRlICAn6ZuG6KiI6ZaL5aeL5pelCiAgICBEaW0gZW5kX2RhdGUgQXMgRGF0ZSAgICAn6ZuG6KiI57WC5LqG5pelCiAgICBEaW0gc2RhdGUgQXMgRGF0ZSAgICAgICAn5rue5Zyo6ICF44Gu5rue5Zyo6ZaL5aeL5pelCiAgICBEaW0gZWRhdGUgQXMgRGF0ZSAgICAgICAn5rue5Zyo6ICF44Gu5rue5Zyo57WC5LqG5pelCiAgICBEaW0gd2RhdGUgQXMgRGF0ZQogICAgU2V0IHdzMSA9IFdvcmtzaGVldHMoIua7nuWcqOS6iOWumiIpCiAgICBTZXQgd3MyID0gV29ya3NoZWV0cygi6ZuG6KiI57WQ5p6cIikKICAgIGxhc3RSb3cgPSB3czEuQ2VsbHMoUm93cy5jb3VudCwgIkIiKS5FbmQoeGxVcCkuUm93ICAgICAgJ0LliJfmnIDntYLooYzlj5blvpcKICAgIElmIGxhc3RSb3cgPCAzIFRoZW4KICAgICAgICBNc2dCb3ggKCLmu57lnKjogIXjgarjgZciKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICfpm4boqIjplovlp4vml6Xjgajpm4boqIjntYLkuobml6XjgpLmsbrlrprjgZnjgovvvIjliY3ms4rjga7mloflrZfliJfjg4Hjgqfjg4Pjgq/lkKvjgoDvvIkKICAgIHN0YXJ0X2RhdGUgPSBEYXRlU2VyaWFsKDIxMDAsIDEsIDEpCiAgICBlbmRfZGF0ZSA9IERhdGVTZXJpYWwoMjAwMCwgMSwgMSkKICAgIEZvciByb3cxID0gMyBUbyBsYXN0Um93CiAgICAgICAgJ+WJjeaziuOBruaWh+Wtl+ODgeOCp+ODg+OCrwogICAgICAgIElmIHdzMS5DZWxscyhyb3cxLCAiRCIpLlZhbHVlIDw+ICIiIEFuZCB3czEuQ2VsbHMocm93MSwgIkQiKS5WYWx1ZSA8PiAi5YmN5rOKIiBUaGVuCiAgICAgICAgICAgIENhbGwgZXJyX3Byb2Mod3MxLCB3czEuQ2VsbHMocm93MSwgIkQiKSwgIuWJjeaziuS7peWkluOBruaWh+WtlyIpCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+WHuueZuuaXpeODgeOCp+ODg+OCrwogICAgICAgIElmIElzRGF0ZSh3czEuQ2VsbHMocm93MSwgIkUiKS5WYWx1ZSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIENhbGwgZXJyX3Byb2Mod3MxLCB3czEuQ2VsbHMocm93MSwgIkUiKSwgIuaXpeS7mOS4jeatoyIpCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+W4sOWuheaXpeODgeOCp+ODg+OCrwogICAgICAgIElmIElzRGF0ZSh3czEuQ2VsbHMocm93MSwgIkYiKS5WYWx1ZSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIENhbGwgZXJyX3Byb2Mod3MxLCB3czEuQ2VsbHMocm93MSwgIkYiKSwgIuaXpeS7mOS4jeatoyIpCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+WHuueZuuaXpTzluLDlroXml6XjgafjgYLjgovjgZPjgajjga7jg4Hjgqfjg4Pjgq8KICAgICAgICBJZiB3czEuQ2VsbHMocm93MSwgIkUiKS5WYWx1ZSA+PSB3czEuQ2VsbHMocm93MSwgIkYiKS5WYWx1ZSBUaGVuCiAgICAgICAgICAgIENhbGwgZXJyX3Byb2Mod3MxLCB3czEuQ2VsbHMocm93MSwgIkYiKSwgIuaXpeS7mOmghuW6j+S4jeatoyIpCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+WHuueZuuaXpeOBjHN0YXJ0X2RhdGXjgojjgorliY3jgarjgolzdGFydF9kYXRl44KS5pu05pawCiAgICAgICAgSWYgd3MxLkNlbGxzKHJvdzEsICJFIikuVmFsdWUgPCBzdGFydF9kYXRlIFRoZW4KICAgICAgICAgICAgc3RhcnRfZGF0ZSA9IHdzMS5DZWxscyhyb3cxLCAiRSIpLlZhbHVlCiAgICAgICAgRW5kIElmCiAgICAgICAgJ+W4sOWuheaXpeOBjGVuZF9kYXRl44KI44KK5b6M44Gq44KJZW5kX2RhdGXjgpLmm7TmlrAKICAgICAgICBJZiB3czEuQ2VsbHMocm93MSwgIkYiKS5WYWx1ZSA+IGVuZF9kYXRlIFRoZW4KICAgICAgICAgICAgZW5kX2RhdGUgPSB3czEuQ2VsbHMocm93MSwgIkYiKS5WYWx1ZQogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ+mbhuioiOe1kOaenOOCr+ODquOCogogICAgd3MyLkNlbGxzLkNsZWFyQ29udGVudHMKICAgIHdzMi5DZWxscygxLCAiQSIpLlZhbHVlID0gIuaXpeS7mCIKICAgIHdzMi5DZWxscygxLCAiQiIpLlZhbHVlID0gIuS6uuaVsCIKICAgICfpm4boqIjplovlp4vml6XvvZ7pm4boqIjntYLkuobml6XoqK3lrpoKICAgIHJvdzIgPSAyCiAgICBGb3Igd2RhdGUgPSBzdGFydF9kYXRlIFRvIGVuZF9kYXRlCiAgICAgICAgd3MyLkNlbGxzKHJvdzIsICJBIikuVmFsdWUgPSB3ZGF0ZQogICAgICAgIHJvdzIgPSByb3cyICsgMQogICAgTmV4dAogICAgJ+a7nuWcqOiAheOBrua7nuWcqOacn+mWk+OCkuioreWumgogICAgRm9yIHJvdzEgPSAzIFRvIGxhc3RSb3cKICAgICAgICBzZGF0ZSA9IHdzMS5DZWxscyhyb3cxLCAiRSIpLlZhbHVlCiAgICAgICAgZWRhdGUgPSB3czEuQ2VsbHMocm93MSwgIkYiKS5WYWx1ZQogICAgICAgICfliY3ms4rjgarjgonnv4zml6XjgYvjgonjgqvjgqbjg7Pjg4jjgZnjgosKICAgICAgICBJZiB3czEuQ2VsbHMocm93MSwgIkQiKS5WYWx1ZSA9ICLliY3ms4oiIFRoZW4KICAgICAgICAgICAgc2RhdGUgPSBzZGF0ZSArIDEKICAgICAgICBFbmQgSWYKICAgICAgICAn5rue5Zyo6ZaL5aeL5pel772e5rue5Zyo57WC5LqG5pel44G+44Gn57mw44KK6L+U44GZCiAgICAgICAgRm9yIHdkYXRlID0gc2RhdGUgVG8gZWRhdGUKICAgICAgICAgICAgJ+mbhuioiOe1kOaenOOBruihjOeVquWPt+OCkueul+WHuuOBmeOCiwogICAgICAgICAgICByb3cyID0gd2RhdGUgLSBzdGFydF9kYXRlICsgMgogICAgICAgICAgICAn566X5Ye644GX44Gf6KGM44Gr77yR5Yqg566X44GZ44KLCiAgICAgICAgICAgIHdzMi5DZWxscyhyb3cyLCAiQiIpLlZhbHVlID0gd3MyLkNlbGxzKHJvdzIsICJCIikuVmFsdWUgKyAxCiAgICAgICAgTmV4dAogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygon44Ko44Op44O85Yem55CGClByaXZhdGUgU3ViIGVycl9wcm9jKEJ5UmVmIHdzIEFzIFdvcmtzaGVldCwgQnlSZWYgcmcgQXMgUmFuZ2UsIEJ5VmFsIG1zZyBBcyBTdHJpbmcpCiAgICB3cy5BY3RpdmF0ZQogICAgcmcuU2VsZWN0CiAgICBNc2dCb3ggKG1zZykKICAgIEVuZApFbmQgU3ViCg==