Create New Rows based on Start & End Date

[harishs]

Hi Experts,

I am looking for a macro code to create rows per employee based on the start & end date. Each employee will have LOP dates with From & To date, I need to create each row per employee for the dates available between dates.

Attached screenshot for reference.

Regards,
Harish S

 

[DanteAmor]

If your data is like this on sheet 1.

Dante Amor
	A	B	C	D	E	F
1	ID	EMPLOYEE	ATTENDANCE	FROM DATE	TO DATE	STATUS
2	Test 1	Name 1	LOP	03/04/2020	08/04/2020
3	Test 2	Name 2	LOP	25/01/2020	02/02/2020
4	Test 2	Name 2	LOPR	06/02/2020	23/02/2020
Sheet1

The results will be like this on sheet2:

Dante Amor
	A	B	C	D	E	F
1	ID	EMPLOYEE	ATTENDANCE	FROM DATE	TO DATE	STATUS
2	Test 1	Name 1	LOP	03/04/2020	03/04/2020
3	Test 1	Name 1	LOP	04/04/2020	04/04/2020
4	Test 1	Name 1	LOP	05/04/2020	05/04/2020
5	Test 1	Name 1	LOP	06/04/2020	06/04/2020
6	Test 1	Name 1	LOP	07/04/2020	07/04/2020
7	Test 1	Name 1	LOP	08/04/2020	08/04/2020
8	Test 2	Name 2	LOP	25/01/2020	25/01/2020
9	Test 2	Name 2	LOP	26/01/2020	26/01/2020
10	Test 2	Name 2	LOP	27/01/2020	27/01/2020
11	Test 2	Name 2	LOP	28/01/2020	28/01/2020
12	Test 2	Name 2	LOP	29/01/2020	29/01/2020
13	Test 2	Name 2	LOP	30/01/2020	30/01/2020
14	Test 2	Name 2	LOP	31/01/2020	31/01/2020
15	Test 2	Name 2	LOP	01/02/2020	01/02/2020
16	Test 2	Name 2	LOP	02/02/2020	02/02/2020
Sheet2

Try this:

Sub Create_New_Rows()
  Dim a As Variant, b As Variant, nMax As Double
  Dim i As Long, j As Long, k As Long, lr As Long
  '
  With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(3).Row
    a = .Range("A2:F" & lr).Value2
    nMax = Evaluate("=MAX('" & .Name & "'!E2:E" & lr & "-'" & .Name & "'!D2:D" & lr & ")")
    ReDim b(1 To UBound(a) * nMax, 1 To 6)
  End With
  '
  For i = 1 To UBound(a, 1)
    For j = a(i, 4) To a(i, 5)
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = a(i, 3)
      b(k, 4) = j
      b(k, 5) = j
      b(k, 6) = a(i, 6)
    Next
  Next
  '
  With Sheets("Sheet2")
    .Rows("2:" & Rows.Count).ClearContents
    .Range("A2").Resize(k, 6).Value = b
  End With
End Sub

 

[DanteAmor]

If your data is not thousands, here is another macro with a simpler code.

Sub test1()
  Dim c As Range, n As Long, lr As Long
  For Each c In Range("A2", Range("A" & Rows.Count).End(3))
    n = c.Offset(, 4) - c.Offset(, 3) + 1
    lr = Range("H" & Rows.Count).End(3).Row + 1
    Range("H" & lr).Resize(n, 6).Value = Array(c, c.Offset(, 1), c.Offset(, 2), c.Offset(, 3), c.Offset(, 3), c.Offset(, 5))
    Range("K" & lr).Resize(n, 2).DataSeries xlColumns, xlChronological, xlDay, 1, , False
  Next
End Sub

Results in G2 onwards:

Dante Amor
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	ID	EMPLOYEE	ATTENDANCE	FROM DATE	TO DATE	STATUS		ID	EMPLOYEE	ATTENDANCE	FROM DATE	TO DATE	STATUS
2	Test 1	Name 1	LOP	03/04/2020	08/04/2020	st1		Test 1	Name 1	LOP	03/04/2020	03/04/2020	st1
3	Test 2	Name 2	LOP	25/01/2020	02/02/2020	st2		Test 1	Name 1	LOP	04/04/2020	04/04/2020	st1
4	Test 2	Name 2	LOPR	06/02/2020	23/02/2020	st3		Test 1	Name 1	LOP	05/04/2020	05/04/2020	st1
5								Test 1	Name 1	LOP	06/04/2020	06/04/2020	st1
6								Test 1	Name 1	LOP	07/04/2020	07/04/2020	st1
7								Test 1	Name 1	LOP	08/04/2020	08/04/2020	st1
8								Test 2	Name 2	LOP	25/01/2020	25/01/2020	st2
9								Test 2	Name 2	LOP	26/01/2020	26/01/2020	st2
10								Test 2	Name 2	LOP	27/01/2020	27/01/2020	st2
11								Test 2	Name 2	LOP	28/01/2020	28/01/2020	st2
12								Test 2	Name 2	LOP	29/01/2020	29/01/2020	st2
13								Test 2	Name 2	LOP	30/01/2020	30/01/2020	st2
14								Test 2	Name 2	LOP	31/01/2020	31/01/2020	st2
15								Test 2	Name 2	LOP	01/02/2020	01/02/2020	st2
16								Test 2	Name 2	LOP	02/02/2020	02/02/2020	st2
Sheet1

 

[harishs]

Hi Dante,

Thank You So Much, both your codes work like a charm.

Regards,
Harish S

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.