將日曆放入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月）是週五，由其下一個單元格（8小時）填補。接下來，宏必須採取第二行，並從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