Hi madball87
See if this code does as you require
Option Explicit
Sub insert_rows()
Dim rng As Range
Dim LR As Long
Dim i As Long
Dim x As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A4:A" & LR)
With rng
For i = LR To 2 Step -1
x = DateDiff("d", rng(i).Offset(-1, 0).Value, rng(i).Value)
If x > 1 Then
rng(i).Resize(x - 1, 1).EntireRow.Insert
Range(rng(i).Offset(-1, 0).Address).AutoFill Destination:=Range(rng(i).Offset(-1, 0).Address & ":" & rng(i).Offset(x - 1, 0).Address), Type:=xlFillDefault
Range(rng(i).Offset(-1, 1).Address).Copy Destination:=Range(rng(i).Offset(0, 1).Address & ":" & rng(i).Offset(x - 2, 1).Address)
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Bookmarks