Option Explicit
 
Public Sub 番号転記()
    Dim sh1 As Worksheet                'Sheet1
    Dim sh2 As Worksheet                'Sheet2
    Dim st_day As Variant               '月初日
    Dim en_day As Variant               '月末日
    Dim flag As Boolean
    Dim maxrow1 As Long                 'Sheet1の最大行数
    Dim maxrow2 As Long                 'Sheet2の最大行数
    Dim row1 As Long
    Dim row2 As Long
    Dim col2 As Long
    Dim i As Long
    Dim pcount As Long                  '登録人数
    Dim dicT As Object                  'dictionary キー：担当者　値：Sheet2の行番号
    Dim arr As Variant                  'dictionaryの値（arr(0)=行番号,arr(1)=日付,arr(2)=番号,arr(3)=段数）
    Dim key As Variant                  'キー（担当者）
    Dim wdate As Variant
    Dim wno As Long
    Dim dd As Long
    Set dicT = CreateObject("Scripting.Dictionary")
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    '開始日取得
    st_day = sh2.Cells(1, "B").Value
    If IsDate(st_day) = True Then
        If day(st_day) = 1 Then
            flag = True
        End If
    End If
    If flag = False Then
        MsgBox ("Sheet2 B2日付不正")
        Exit Sub
    End If
    '月末日取得
    en_day = GetLastDay(st_day)
    maxrow2 = sh2.Cells(Rows.count, "A").End(xlUp).Row '最終行を求める
    If maxrow2 < 5 Then Exit Sub
    If (maxrow2 - 5) Mod 4 <> 0 Then
        MsgBox ("Sheet2 A列最大行数エラー")
        Exit Sub
    End If
    pcount = ((maxrow2 - 5) \ 4) + 1
    'Sheet2の担当者を記憶
    For i = 1 To pcount
        row2 = 5 + (i - 1) * 4
        key = sh2.Cells(row2, "A").Value
        If dicT.exists(key) = True Then
            MsgBox ("Sheet2 重複担当者:" & key)
            Exit Sub
        End If
        arr = Array(row2, 0, 0, 0)
        dicT(key) = arr
    Next
    'Sheet2の初期化
    For i = 1 To pcount
        row2 = 5 + (i - 1) * 4
        For dd = 1 To day(en_day)
            col2 = 2 + (dd - 1) * 4
            sh2.Cells(row2, col2 + 1).ClearContents         '1段目開始番号
            sh2.Cells(row2, col2 + 3).ClearContents         '1段目終了番号
            sh2.Cells(row2 + 1, col2 + 1).ClearContents     '2段目開始番号
            sh2.Cells(row2 + 1, col2 + 3).ClearContents     '2段目終了番号
            sh2.Cells(row2 + 2, col2 + 1).ClearContents     '3段目開始番号
            sh2.Cells(row2 + 2, col2 + 3).ClearContents     '3段目終了番号
            sh2.Cells(row2 + 3, col2 + 3).ClearContents     '小計
        Next
    Next
    'Sheet1を最終行まで処理する
    maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row '最終行を求める
    For row1 = 2 To maxrow1
        wno = sh1.Cells(row1, "A").Value    '番号
        wdate = sh1.Cells(row1, "C").Value  '日付
        key = sh1.Cells(row1, "D").Value    '担当者
        If dicT.exists(key) = False Then
            Call ErrorMsg(sh1, row1, "担当者未登録:" & key)
        End If
        flag = False
        If IsDate(wdate) = True And wdate >= st_day And wdate <= en_day Then flag = True
        If flag = False Then
            Call ErrorMsg(sh1, row1, "日付不正:" & wdate)
        End If
        arr = dicT(key)
        '行番号、列番号決定
        row2 = arr(0)
        col2 = 2 + (wdate - st_day) * 4
        '日付戻りチェック
        If arr(1) > 0 And wdate < arr(1) Then
            Call ErrorMsg(sh1, row1, "日付戻り発生:" & wdate)
        End If
        '番号戻りチェック
        If arr(2) > 0 And wno <= arr(2) Then
            Call ErrorMsg(sh1, row1, "番号戻り発生:" & wno)
        End If
        '日付変更発生時
        If wdate > arr(1) Then
            arr(1) = wdate  '日付更新
            arr(2) = wno    '番号更新
            arr(3) = 1      '段数設定
            sh2.Cells(row2 + arr(3) - 1, col2 + 1).Value = wno      '開始番号
            sh2.Cells(row2 + arr(3) - 1, col2 + 3).Value = wno      '終了番号
        Else
        '日付が前回と同じ場合、
            '番号に飛びがないなら、終了番号のみ更新
            If arr(2) + 1 = wno Then
                sh2.Cells(row2 + arr(3) - 1, col2 + 3).Value = wno      '終了番号
            Else
            '番号が飛んでいるなら、次の段へ移動
                arr(3) = arr(3) + 1
                If arr(3) > 3 Then
                    Call ErrorMsg(sh1, row1, "段数オーバー")
                End If
                sh2.Cells(row2 + arr(3) - 1, col2 + 1).Value = wno      '開始番号
                sh2.Cells(row2 + arr(3) - 1, col2 + 3).Value = wno      '終了番号
            End If
            arr(2) = wno    '番号更新（日付は更新不要、段数は設定済み）
        End If
        dicT(key) = arr     '値を戻す
        '計更新
        sh2.Cells(row2 + 3, col2 + 3).Value = sh2.Cells(row2 + 3, col2 + 3).Value + 1
    Next
    MsgBox ("完了")
End Sub
 
'エラーメッセージ出力＆停止
Private Sub ErrorMsg(ByVal ws As Worksheet, ByVal wrow As Long, ByVal msg As String)
    MsgBox ("Sheet1 " & wrow & "行　" & msg)
    ws.Activate
    ws.Cells(wrow, 1).Select
    End
End Sub
 
'月末日取得
Private Function GetLastDay(ByVal st_day As Variant) As Variant
    Dim yyyy As Long
    Dim mm As Long
    Dim wday As Date
    yyyy = Year(st_day)
    mm = Month(st_day)
    mm = mm + 1
    If mm > 12 Then
        yyyy = yyyy + 1
        mm = 1
    End If
    wday = DateSerial(yyyy, mm, 1)
    GetLastDay = wday - 1
End Function
 
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOeVquWPt+i7ouiomCgpCiAgICBEaW0gc2gxIEFzIFdvcmtzaGVldCAgICAgICAgICAgICAgICAnU2hlZXQxCiAgICBEaW0gc2gyIEFzIFdvcmtzaGVldCAgICAgICAgICAgICAgICAnU2hlZXQyCiAgICBEaW0gc3RfZGF5IEFzIFZhcmlhbnQgICAgICAgICAgICAgICAn5pyI5Yid5pelCiAgICBEaW0gZW5fZGF5IEFzIFZhcmlhbnQgICAgICAgICAgICAgICAn5pyI5pyr5pelCiAgICBEaW0gZmxhZyBBcyBCb29sZWFuCiAgICBEaW0gbWF4cm93MSBBcyBMb25nICAgICAgICAgICAgICAgICAnU2hlZXQx44Gu5pyA5aSn6KGM5pWwCiAgICBEaW0gbWF4cm93MiBBcyBMb25nICAgICAgICAgICAgICAgICAnU2hlZXQy44Gu5pyA5aSn6KGM5pWwCiAgICBEaW0gcm93MSBBcyBMb25nCiAgICBEaW0gcm93MiBBcyBMb25nCiAgICBEaW0gY29sMiBBcyBMb25nCiAgICBEaW0gaSBBcyBMb25nCiAgICBEaW0gcGNvdW50IEFzIExvbmcgICAgICAgICAgICAgICAgICAn55m76Yyy5Lq65pWwCiAgICBEaW0gZGljVCBBcyBPYmplY3QgICAgICAgICAgICAgICAgICAnZGljdGlvbmFyeSDjgq3jg7zvvJrmi4XlvZPogIXjgIDlgKTvvJpTaGVldDLjga7ooYznlarlj7cKICAgIERpbSBhcnIgQXMgVmFyaWFudCAgICAgICAgICAgICAgICAgICdkaWN0aW9uYXJ544Gu5YCk77yIYXJyKDApPeihjOeVquWPtyxhcnIoMSk95pel5LuYLGFycigyKT3nlarlj7csYXJyKDMpPeauteaVsO+8iQogICAgRGltIGtleSBBcyBWYXJpYW50ICAgICAgICAgICAgICAgICAgJ+OCreODvO+8iOaLheW9k+iAhe+8iQogICAgRGltIHdkYXRlIEFzIFZhcmlhbnQKICAgIERpbSB3bm8gQXMgTG9uZwogICAgRGltIGRkIEFzIExvbmcKICAgIFNldCBkaWNUID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpCiAgICBTZXQgc2gxID0gV29ya3NoZWV0cygiU2hlZXQxIikKICAgIFNldCBzaDIgPSBXb3Jrc2hlZXRzKCJTaGVldDIiKQogICAgJ+mWi+Wni+aXpeWPluW+lwogICAgc3RfZGF5ID0gc2gyLkNlbGxzKDEsICJCIikuVmFsdWUKICAgIElmIElzRGF0ZShzdF9kYXkpID0gVHJ1ZSBUaGVuCiAgICAgICAgSWYgZGF5KHN0X2RheSkgPSAxIFRoZW4KICAgICAgICAgICAgZmxhZyA9IFRydWUKICAgICAgICBFbmQgSWYKICAgIEVuZCBJZgogICAgSWYgZmxhZyA9IEZhbHNlIFRoZW4KICAgICAgICBNc2dCb3ggKCJTaGVldDIgQjLml6Xku5jkuI3mraMiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICfmnIjmnKvml6Xlj5blvpcKICAgIGVuX2RheSA9IEdldExhc3REYXkoc3RfZGF5KQogICAgbWF4cm93MiA9IHNoMi5DZWxscyhSb3dzLmNvdW50LCAiQSIpLkVuZCh4bFVwKS5Sb3cgJ+acgOe1guihjOOCkuaxguOCgeOCiwogICAgSWYgbWF4cm93MiA8IDUgVGhlbiBFeGl0IFN1YgogICAgSWYgKG1heHJvdzIgLSA1KSBNb2QgNCA8PiAwIFRoZW4KICAgICAgICBNc2dCb3ggKCJTaGVldDIgQeWIl+acgOWkp+ihjOaVsOOCqOODqeODvCIpCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgcGNvdW50ID0gKChtYXhyb3cyIC0gNSkgXCA0KSArIDEKICAgICdTaGVldDLjga7mi4XlvZPogIXjgpLoqJjmhrYKICAgIEZvciBpID0gMSBUbyBwY291bnQKICAgICAgICByb3cyID0gNSArIChpIC0gMSkgKiA0CiAgICAgICAga2V5ID0gc2gyLkNlbGxzKHJvdzIsICJBIikuVmFsdWUKICAgICAgICBJZiBkaWNULmV4aXN0cyhrZXkpID0gVHJ1ZSBUaGVuCiAgICAgICAgICAgIE1zZ0JveCAoIlNoZWV0MiDph43opIfmi4XlvZPogIU6IiAmIGtleSkKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICBhcnIgPSBBcnJheShyb3cyLCAwLCAwLCAwKQogICAgICAgIGRpY1Qoa2V5KSA9IGFycgogICAgTmV4dAogICAgJ1NoZWV0MuOBruWIneacn+WMlgogICAgRm9yIGkgPSAxIFRvIHBjb3VudAogICAgICAgIHJvdzIgPSA1ICsgKGkgLSAxKSAqIDQKICAgICAgICBGb3IgZGQgPSAxIFRvIGRheShlbl9kYXkpCiAgICAgICAgICAgIGNvbDIgPSAyICsgKGRkIC0gMSkgKiA0CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCBjb2wyICsgMSkuQ2xlYXJDb250ZW50cyAgICAgICAgICcx5q6155uu6ZaL5aeL55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCBjb2wyICsgMykuQ2xlYXJDb250ZW50cyAgICAgICAgICcx5q6155uu57WC5LqG55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgMSwgY29sMiArIDEpLkNsZWFyQ29udGVudHMgICAgICcy5q6155uu6ZaL5aeL55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgMSwgY29sMiArIDMpLkNsZWFyQ29udGVudHMgICAgICcy5q6155uu57WC5LqG55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgMiwgY29sMiArIDEpLkNsZWFyQ29udGVudHMgICAgICcz5q6155uu6ZaL5aeL55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgMiwgY29sMiArIDMpLkNsZWFyQ29udGVudHMgICAgICcz5q6155uu57WC5LqG55Wq5Y+3CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgMywgY29sMiArIDMpLkNsZWFyQ29udGVudHMgICAgICflsI/oqIgKICAgICAgICBOZXh0CiAgICBOZXh0CiAgICAnU2hlZXQx44KS5pyA57WC6KGM44G+44Gn5Yem55CG44GZ44KLCiAgICBtYXhyb3cxID0gc2gxLkNlbGxzKFJvd3MuY291bnQsICJBIikuRW5kKHhsVXApLlJvdyAn5pyA57WC6KGM44KS5rGC44KB44KLCiAgICBGb3Igcm93MSA9IDIgVG8gbWF4cm93MQogICAgICAgIHdubyA9IHNoMS5DZWxscyhyb3cxLCAiQSIpLlZhbHVlICAgICfnlarlj7cKICAgICAgICB3ZGF0ZSA9IHNoMS5DZWxscyhyb3cxLCAiQyIpLlZhbHVlICAn5pel5LuYCiAgICAgICAga2V5ID0gc2gxLkNlbGxzKHJvdzEsICJEIikuVmFsdWUgICAgJ+aLheW9k+iAhQogICAgICAgIElmIGRpY1QuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIENhbGwgRXJyb3JNc2coc2gxLCByb3cxLCAi5ouF5b2T6ICF5pyq55m76YyyOiIgJiBrZXkpCiAgICAgICAgRW5kIElmCiAgICAgICAgZmxhZyA9IEZhbHNlCiAgICAgICAgSWYgSXNEYXRlKHdkYXRlKSA9IFRydWUgQW5kIHdkYXRlID49IHN0X2RheSBBbmQgd2RhdGUgPD0gZW5fZGF5IFRoZW4gZmxhZyA9IFRydWUKICAgICAgICBJZiBmbGFnID0gRmFsc2UgVGhlbgogICAgICAgICAgICBDYWxsIEVycm9yTXNnKHNoMSwgcm93MSwgIuaXpeS7mOS4jeatozoiICYgd2RhdGUpCiAgICAgICAgRW5kIElmCiAgICAgICAgYXJyID0gZGljVChrZXkpCiAgICAgICAgJ+ihjOeVquWPt+OAgeWIl+eVquWPt+axuuWumgogICAgICAgIHJvdzIgPSBhcnIoMCkKICAgICAgICBjb2wyID0gMiArICh3ZGF0ZSAtIHN0X2RheSkgKiA0CiAgICAgICAgJ+aXpeS7mOaIu+OCiuODgeOCp+ODg+OCrwogICAgICAgIElmIGFycigxKSA+IDAgQW5kIHdkYXRlIDwgYXJyKDEpIFRoZW4KICAgICAgICAgICAgQ2FsbCBFcnJvck1zZyhzaDEsIHJvdzEsICLml6Xku5jmiLvjgornmbrnlJ86IiAmIHdkYXRlKQogICAgICAgIEVuZCBJZgogICAgICAgICfnlarlj7fmiLvjgorjg4Hjgqfjg4Pjgq8KICAgICAgICBJZiBhcnIoMikgPiAwIEFuZCB3bm8gPD0gYXJyKDIpIFRoZW4KICAgICAgICAgICAgQ2FsbCBFcnJvck1zZyhzaDEsIHJvdzEsICLnlarlj7fmiLvjgornmbrnlJ86IiAmIHdubykKICAgICAgICBFbmQgSWYKICAgICAgICAn5pel5LuY5aSJ5pu055m655Sf5pmCCiAgICAgICAgSWYgd2RhdGUgPiBhcnIoMSkgVGhlbgogICAgICAgICAgICBhcnIoMSkgPSB3ZGF0ZSAgJ+aXpeS7mOabtOaWsAogICAgICAgICAgICBhcnIoMikgPSB3bm8gICAgJ+eVquWPt+abtOaWsAogICAgICAgICAgICBhcnIoMykgPSAxICAgICAgJ+auteaVsOioreWumgogICAgICAgICAgICBzaDIuQ2VsbHMocm93MiArIGFycigzKSAtIDEsIGNvbDIgKyAxKS5WYWx1ZSA9IHdubyAgICAgICfplovlp4vnlarlj7cKICAgICAgICAgICAgc2gyLkNlbGxzKHJvdzIgKyBhcnIoMykgLSAxLCBjb2wyICsgMykuVmFsdWUgPSB3bm8gICAgICAn57WC5LqG55Wq5Y+3CiAgICAgICAgRWxzZQogICAgICAgICfml6Xku5jjgYzliY3lm57jgajlkIzjgZjloLTlkIjjgIEKICAgICAgICAgICAgJ+eVquWPt+OBq+mjm+OBs+OBjOOBquOBhOOBquOCieOAgee1guS6hueVquWPt+OBruOBv+abtOaWsAogICAgICAgICAgICBJZiBhcnIoMikgKyAxID0gd25vIFRoZW4KICAgICAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyICsgYXJyKDMpIC0gMSwgY29sMiArIDMpLlZhbHVlID0gd25vICAgICAgJ+e1guS6hueVquWPtwogICAgICAgICAgICBFbHNlCiAgICAgICAgICAgICfnlarlj7fjgYzpo5vjgpPjgafjgYTjgovjgarjgonjgIHmrKHjga7mrrXjgbjnp7vli5UKICAgICAgICAgICAgICAgIGFycigzKSA9IGFycigzKSArIDEKICAgICAgICAgICAgICAgIElmIGFycigzKSA+IDMgVGhlbgogICAgICAgICAgICAgICAgICAgIENhbGwgRXJyb3JNc2coc2gxLCByb3cxLCAi5q615pWw44Kq44O844OQ44O8IikKICAgICAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICAgICAgc2gyLkNlbGxzKHJvdzIgKyBhcnIoMykgLSAxLCBjb2wyICsgMSkuVmFsdWUgPSB3bm8gICAgICAn6ZaL5aeL55Wq5Y+3CiAgICAgICAgICAgICAgICBzaDIuQ2VsbHMocm93MiArIGFycigzKSAtIDEsIGNvbDIgKyAzKS5WYWx1ZSA9IHdubyAgICAgICfntYLkuobnlarlj7cKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIGFycigyKSA9IHdubyAgICAn55Wq5Y+35pu05paw77yI5pel5LuY44Gv5pu05paw5LiN6KaB44CB5q615pWw44Gv6Kit5a6a5riI44G/77yJCiAgICAgICAgRW5kIElmCiAgICAgICAgZGljVChrZXkpID0gYXJyICAgICAn5YCk44KS5oi744GZCiAgICAgICAgJ+ioiOabtOaWsAogICAgICAgIHNoMi5DZWxscyhyb3cyICsgMywgY29sMiArIDMpLlZhbHVlID0gc2gyLkNlbGxzKHJvdzIgKyAzLCBjb2wyICsgMykuVmFsdWUgKyAxCiAgICBOZXh0CiAgICBNc2dCb3ggKCLlrozkuoYiKQpFbmQgU3ViCgon44Ko44Op44O844Oh44OD44K744O844K45Ye65Yqb77yG5YGc5q2iClByaXZhdGUgU3ViIEVycm9yTXNnKEJ5VmFsIHdzIEFzIFdvcmtzaGVldCwgQnlWYWwgd3JvdyBBcyBMb25nLCBCeVZhbCBtc2cgQXMgU3RyaW5nKQogICAgTXNnQm94ICgiU2hlZXQxICIgJiB3cm93ICYgIuihjOOAgCIgJiBtc2cpCiAgICB3cy5BY3RpdmF0ZQogICAgd3MuQ2VsbHMod3JvdywgMSkuU2VsZWN0CiAgICBFbmQKRW5kIFN1YgoKJ+aciOacq+aXpeWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldExhc3REYXkoQnlWYWwgc3RfZGF5IEFzIFZhcmlhbnQpIEFzIFZhcmlhbnQKICAgIERpbSB5eXl5IEFzIExvbmcKICAgIERpbSBtbSBBcyBMb25nCiAgICBEaW0gd2RheSBBcyBEYXRlCiAgICB5eXl5ID0gWWVhcihzdF9kYXkpCiAgICBtbSA9IE1vbnRoKHN0X2RheSkKICAgIG1tID0gbW0gKyAxCiAgICBJZiBtbSA+IDEyIFRoZW4KICAgICAgICB5eXl5ID0geXl5eSArIDEKICAgICAgICBtbSA9IDEKICAgIEVuZCBJZgogICAgd2RheSA9IERhdGVTZXJpYWwoeXl5eSwgbW0sIDEpCiAgICBHZXRMYXN0RGF5ID0gd2RheSAtIDEKRW5kIEZ1bmN0aW9uCgo=