Convert Date Range to Daily Rows

[willbost]

I have a spreadsheet that lists the following information in rows:

Name ID Begin Date End Date Hours per Day
Joe Smith 10001 3/18/2013 3/22/2018 8
Jane Smith 11001 8/26/2013 9/19/2013 4

There are a lot more rows, but that represents the 5 columns of data. I need to transform the data in such a ways as I get the following for Joe Smith listed above (and all others that are listed in the current sheet) on a new sheet using a macro/VBA:

Name ID Date Hours per Day
Joe Smith 10001 3/18/2013 8
Joe Smith 10001 3/19/2013 8
Joe Smith 10001 3/20/2013 8
Joe Smith 10001 3/21/2013 8
Joe Smith 10001 3/22/2013 8

As you see, it needs to look at the date range and create a new row for each individual day. As well as only provide weekdays (WORKDAYS).

 

[VBA Geek]

Sub OGFTREW()
Dim x As Long, y As Long
Dim anArray
Dim vArr
Dim cnt As Long: cnt = 0
With Range("A1").CurrentRegion
    vArr = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
ReDim anArray(3, 0)
For x = 1 To UBound(vArr)
    For y = vArr(x, 3) To vArr(x, 4)
    If Weekday(y) <> 1 And Weekday(y) <> 7 Then
        ReDim Preserve anArray(3, cnt)
        anArray(0, cnt) = vArr(x, 1)
        anArray(1, cnt) = vArr(x, 2)
        anArray(2, cnt) = y
        anArray(3, cnt) = vArr(x, 5)
        cnt = cnt + 1
    End If
    Next
Next
Sheet2.Range("A1:d1") = Array("Name", "ID", "Date", "Hours Per Day")
Sheet2.Range("A2").Resize(UBound(anArray, 2) + 1, 4) = Application.Transpose(anArray)


MsgBox "Done"
End Sub

 

[willbost]

Thanks for the quick answer. Looks pretty good. For some reason the Hours per Day column keeps the date format and I had to change it back. Is there anyway to have it put the results on another tab vs. overwriting the original data?

 

[Rick Rothstein]

Here is another macro you can consider (change the red highlighted text to the output worksheet's name)...

Sub ExpandDatesPerName()
  Dim X As Long, D As Long, Index As Long, LastRow As Long
  Dim ArrayData As Variant, ArrayOut As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  ArrayData = Range("A2:E" & LastRow)
  ReDim ArrayOut(1 To Evaluate("Sum(D2:D" & LastRow & "-C2:C" & LastRow & "+1)"), 1 To 4)
  For X = 1 To UBound(ArrayData)
    For D = ArrayData(X, 3) To ArrayData(X, 4)
      If Weekday(D, vbMonday) < 6 Then
        Index = Index + 1
        ArrayOut(Index, 1) = ArrayData(X, 1)
        ArrayOut(Index, 2) = ArrayData(X, 2)
        ArrayOut(Index, 3) = D
        ArrayOut(Index, 4) = ArrayData(X, 5)
      End If
    Next
  Next
  With Worksheets("Sheet2").Range("A2").Resize(UBound(ArrayOut), 4)
    .Parent.Range("A1:D1").Value = Array("Name", "ID", "Date", "Hours Per Day")
    .Cells = ArrayOut
    Intersect(.Cells, .Columns("C")).NumberFormat = "m/dd/yyyy"
  End With
End Sub

 

[VBA Geek]

i used "sheet2" to implicitly refer to another sheet, I should have pointed it out

for the cells format you can use Rick's example