Sub MyCopy()
Dim lr As Long
Dim r As Long
Application.ScreenUpdating = False
' Find last row in column E with data
lr = Cells(Rows.Count, "E").End(xlUp).Row
' If there are any values in column E, loop through column E backwards, from last row to first
If lr > 2 Then
For r = lr To 2 Step -1
' See if anything in column E
If Cells(r, "E") <> "" Then
' Insert blank row below
Rows(r + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' Copy value from row to new row
Rows(r).Copy Rows(r + 1)
' Clear value from column E on current row
Cells(r, "E").ClearContents
End If
Next r
End If
Application.ScreenUpdating = True
End Sub
This Worked. Thank you for your time. We worked on this for several weeks off and on but just could not get it right.Try this code:
VBA Code:Sub MyCopy() Dim lr As Long Dim r As Long Application.ScreenUpdating = False ' Find last row in column E with data lr = Cells(Rows.Count, "E").End(xlUp).Row ' If there are any values in column E, loop through column E backwards, from last row to first If lr > 2 Then For r = lr To 2 Step -1 ' See if anything in column E If Cells(r, "E") <> "" Then ' Insert blank row below Rows(r + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ' Copy value from row to new row Rows(r).Copy Rows(r + 1) ' Clear value from column E on current row Cells(r, "E").ClearContents End If Next r End If Application.ScreenUpdating = True End Sub