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日至2月）是星期五，下一个小区（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

宏将日历导入Excel 2007

1 个答案: