Duplicate rows, based on date difference

[Ixtreme]

I have a sheet with dates in both column E and F. If the date in
column F is greater than the date in column E, the specific row needs
to be copied a number of times, depending on the number of days
between the date in colums F and E.

Example:


row columns E column F
1 16-01-72 16-01-72
2 18-01-79 20-01-83


In this case, row 2 needs to be copied automatically 4 times here ( 1
for '80, 1 for
'81, 1 for '82 and 1 for '83). The date in column E should change
accordingly. So eventually I end up with the following rows:

row columns E column F
1 16-01-72 16-01-72
2 18-01-79 20-01-83
3 18-01-80 20-01-83
4 18-01-81 20-01-83
5 18-01-82 20-01-83
6 18-01-83 20-01-83

(Column F will be deleted)


Thanks for your help !!


Mark

 

[Bob Phillips]

I guess you mean years not days

Public Sub ProcessData()
Const TEST_COLUMN As String = "E" '<=== change to suit
Dim i As Long, j As Long
Dim iLastRow As Long
Dim cYears As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = iLastRow To 1 Step -1
cYears = Year(.Cells(i, "F").Value) - Year(.Cells(i,
TEST_COLUMN).Value)
If cYears > 1 Then
.Rows(i + 1).Resize(cYears - 1).Insert
For j = 1 To cYears - 1
.Cells(i + j, TEST_COLUMN).Value = DateSerial( _
Year(.Cells(i, TEST_COLUMN).Value) + j, _
Month(.Cells(i, TEST_COLUMN).Value), _
Day(.Cells(i, TEST_COLUMN).Value))
.Cells(i + j, "F").Value = .Cells(i, "F").Value
Next j
End If
Next i
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Ixtreme]

Bob, thank you very much for your answer!

One more question: If I want to do the same trick based on a
difference in days, what would be the code in that case?

Thanks!

Mark

 

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "E" '<=== change to suit
Dim i As Long, j As Long
Dim iLastRow As Long
Dim cDays As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = iLastRow To 1 Step -1
cDays = .Cells(i, "F").Value - _
.Cells(i, TEST_COLUMN).Value
If cDays > 1 Then
.Rows(i + 1).Resize(cDays - 1).Insert
For j = 1 To cDays - 1
.Cells(i + j, TEST_COLUMN).Value = _
.Cells(i, TEST_COLUMN).Value) + j
.Cells(i + j, "F").Value = .Cells(i, "F").Value
Next j
End If
Next i
End With

End Sub

But you might create an awful lot of rows


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Ixtreme]

The code works, however, if I have the following dates:

E F
16-01-72 18-01-72

It currently creates 1 only extra row. What I need is an extra row for
17-01-72 and also an extra row for 18-01-72.

Is it also possible to first copy the the entire row and then change
the date field to resp. 17-01 and 18-01-72

I am aware of the fact that in some case a lot of rows will be
created ;-)

 

[Bob Phillips]

Sorry, should have removed the -1

Public Sub ProcessData()
Const TEST_COLUMN As String = "E" '<=== change to suit
Dim i As Long, j As Long
Dim iLastRow As Long
Dim cDays As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = iLastRow To 1 Step -1
cDays = .Cells(i, "F").Value - _
.Cells(i, TEST_COLUMN).Value
If cDays > 1 Then
.Rows(i + 1).Resize(cDays - 1).Insert
For j = 1 To cDays
.Cells(i + j, TEST_COLUMN).Value = _
.Cells(i, TEST_COLUMN).Value + j
.Cells(i + j, "F").Value = .Cells(i, "F").Value
Next j
End If
Next i
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Bob Phillips]

Missed the second part of the question

Public Sub ProcessData()
Const TEST_COLUMN As String = "E" '<=== change to suit
Dim i As Long, j As Long
Dim iLastRow As Long
Dim cDays As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = iLastRow To 1 Step -1
cDays = .Cells(i, "F").Value - _
.Cells(i, TEST_COLUMN).Value
If cDays > 1 Then
.Rows(i + 1).Resize(cDays).Insert
For j = 1 To cDays
.Rows(i).Copy .Cells(i + j, "A")
.Cells(i + j, TEST_COLUMN).Value = _
.Cells(i, TEST_COLUMN).Value + j
Next j
End If
Next i
End With

End Sub

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Ixtreme]

That's it !!

In Holland we say "GEWELDIG" (great).

Many thanks,

Mark