Inserting New Row for each not empty cell - EXCEL VBA

[ozonas]

Hello Guys,

I have a small problem with my code - it just keeps inserting new rows without executing the if statement. So basically what I want to do is: I have a spreadsheet with lots of data in it and almost an empty column in between with a couple dates there. If there is a date in that column, I want Excel VBA to insert a new row just bellow that date. Here is my code so far:

Sub newmacro()
Dim rng As Range
Dim cell As Range
Set rng = Range("J3:J40")
For Each cell In rng
If Not IsEmpty(cell.Value) Then
ActiveCell.Offset(1, -9).Select
ActiveCell.EntireRow.Insert
ActiveCell.Offset(1, 9).Select
End If
Next
End Sub

Thank you for your help! Explaining where I went wront would be helpful as well!

 

[ozonas]

Hello again,

So my code at the moment looks like this:
Sub newmacro()
Dim Rng As Range
For Each Rng In Range("J3:J40")
If IsDate(Rng.Value) Then
Rng.Offset(1, 0).EntireRow.Insert
Rng.Offset(0, -4).Cut Destination:=Rng.Offset(1, -4)
Rng.Offset(0, 0).Copy Destination:=Rng.Offset(0, -4)
Rng.Offset(0, 1).Copy Destination:=Rng.Offset(1, -5)
Rng.Offset(0, -8).Copy Destination:=Rng.Offset(1, -8)
Rng.Offset(0, -6).Copy Destination:=Rng.Offset(1, -6)
Rng.Offset(0, -3).Copy Destination:=Rng.Offset(1, -3)
Rng.Offset(0, -1).Copy Destination:=Rng.Offset(1, -1)
Rng.Offset(0, 2).Copy Destination:=Rng.Offset(1, 2)
Rng.Offset(0, 3).Copy Destination:=Rng.Offset(1, 3)
Rng.Offset(1, -2).Cells.Value = "Y"
End If
Next
End Sub

As you can see its mapping appropriate data and pasting it in to the empty cells located in that additional row. However, I want to colour the destination cells in red (or any other colour), so I would be aware of the new data when I will be looking at it again. And this is not working: Rng.Offset(1,0).Interior.Color = 5 . I was trying: ng.Offset(0, 3).Copy Destination:=Rng.Offset(1, 3).Interior.Color = 5

Thank you!