マクロをExcel 2007にカレンダーにする

Question

カレンダーをシートに作成したいのですが、作業日の間に広がる別の列（時間）に従って、別のシートの最初の日付をとって構築する必要があります。 だからたとえば、このために：

date hours 
17/02/2012 8 
20/02/2012 50 
20/02/2012 37 
13/03/2012 110 

になる必要があります。

date hours 
17/02/2012 8 
20/02/2012 8 
21/02/2012 8 
22/02/2012 8 
23/02/2012 8 
24/02/2012 8 
27/02/2012 8 
28/02/2012 2 
20/02/2012 8 
21/02/2012 8 
22/02/2012 8 
23/02/2012 8 
24/02/2012 3 
13/03/2012 8 
14/03/2012 8 
15/03/2012 8 
16/03/2012 8 
19/03/2012 8 
20/03/2012 8 
21/03/2012 8 
22/03/2012 8 
23/03/2012 8 
26/03/2012 8 
27/03/2012 8 
28/03/2012 8 
29/03/2012 8 
30/03/2012 6 

初日（17年02月）は金曜日であり、その次のセル（8時間）で満たされています。次にマクロは2行目を取らなければならず、2月20日（月曜日）から始まり、値（37時間）が翌営業日に広まるまで終了しなければなりません。このように私は生産のための労働者カレンダーを持っています。誰かが私を助けることができますか？ ありがとうございます

Answer 1

これは、サンプルデータを使用して求める出力を生成します。

Option Explicit 
Sub GenerateCalendar() 

    Dim DateCrnt As Date 
    Dim DayOfWeekCrnt As Long 
    Dim HoursToPlace As Long 
    Dim RowDestCrnt As Long 
    Dim RowSrcCrnt As Long 
    Dim RowSrcLast As Long 
    Dim SrcWork() As Variant 

    ' Assume source data starts in row 2 of columns A and B of Worksheet Calendar 1 
    With Worksheets("Calendar 1") 
    ' Find last used row in column A 
    RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row 
    SrcWork = .Range(.Cells(2, "A"), .Cells(RowSrcLast, "B")).Value 
    End With 

    ' SrcWork is now a 2D array containing the data from Calendar1. 
    ' Dimension 1 holds the rows. Dimension 2 holds to columns. 

    ' Initialise control variable for SrcWork 
    RowSrcCrnt = 1 
    DateCrnt = SrcWork(RowSrcCrnt, 1) 
    HoursToPlace = SrcWork(RowSrcCrnt, 2) 
    RowSrcCrnt = 2 

    ' Assume output data is to be placed in in Worksheet Calendar 2 in columns 
    ' A and B starting at row 2 
    RowDestCrnt = 2 

    With Worksheets("Calendar 2") 
    Do While True 
     ' DateCrnt identifies the next date to output. 
     ' HoursToPlace identifies the unplaced hours 
     With .Cells(RowDestCrnt, 1) 
     .Value = DateCrnt 
     .NumberFormat = "ddd d mmm yyy" 
     End With 
     If HoursToPlace > 8 Then 
     .Cells(RowDestCrnt, 2).Value = 8 
     HoursToPlace = HoursToPlace - 8 
     Else 
     .Cells(RowDestCrnt, 2).Value = HoursToPlace 
     HoursToPlace = 0 
     End If 
     RowDestCrnt = RowDestCrnt + 1 
     If HoursToPlace = 0 Then 
     ' No more hours to place from last row of SrcWork 
     If RowSrcCrnt > UBound(SrcWork, 1) Then 
      ' There are no used rows in SrcWork. Finished 
      Exit Do 
     End If 
     ' Extract next row from source data. 
     DateCrnt = SrcWork(RowSrcCrnt, 1) 
     HoursToPlace = SrcWork(RowSrcCrnt, 2) 
     RowSrcCrnt = RowSrcCrnt + 1 
     Else 
     ' More hours to place. Set DateCrnt to the next weekday. 
     Do While True 
      DateCrnt = DateAdd("d", 1, DateCrnt) ' Add 1 day to DateCrnt 
      DayOfWeekCrnt = Weekday(DateCrnt) 
      If DayOfWeekCrnt >= vbMonday And DayOfWeekCrnt <= vbFriday Then 
      ' Have week day 
      Exit Do 
      End If 
     Loop 
     End If 
    Loop 
    End With 

End Sub