Question

I want to make a calendar in a sheet.It must be constructed taking initial date from another sheet, according to another column(hours) that are to spread among the working days.
So for example this:

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

should become:

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

The first day (17-Feb) is Friday and is filled by its next cell (8 hours). Next the macro has to take the second row, and starting from the 20-Feb(Monday), has to finish until the value (37 hours) is spread on next working days. In this way I have a workers ‘ Calendar for production. Someone can help me?
Thanks in advance

Answer 1

This generates the output you seek with your example data.

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