Макрос для превращения календаря в 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 часов).Далее макрос должен занимать вторую строку, и, начиная с 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