Copy paste row content based on date

[kuldeepnagar]

Dear All
I have one sheet named "Active" and data starts in this sheet from B4. I have one more sheet named "Lapsed" and data starts in this sheet from B3.
When date in H column in "Active" sheet in less than now -120 days, code will copy contents of B to G column of respective row and paste in next empty row of "Lapsed" Sheet.
I am facing following issues.
1. If I run code 2 time, it deletes one row from "Lapsed" sheet.
2. If i run code when date condition is met, code will delete last filled row in "Lapsed" sheet, leave one row blank and paste data to next date.

I do not want above to issues. Please support. I started learning VBA and made below code with help of numerous webs from Excel Experts. Your expert opinion will surely be appreciable. Thanks a lot in advance.

Sub RectangleRoundedCorners4_Click()

Application.ScreenUpdating = False


Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, i As Long, j As Long
Dim LastColumn As Long, a As Long, b As Long
Dim rng As Range


Set wsI = Sheets("Active")
Set wsO = Sheets("Lapsed")


Set rng = wsI.Range("B:G")


'Last Row in a Column. Row need to start in row 2
LastRow = wsI.Cells(Rows.Count, "G").End(xlUp).Row


j = wsO.Cells(Rows.Count, "B").End(xlUp).Row


With wsI
   'Loop through each row
    For i = 2 To LastRow
        If .Range("H" & i).Value <= Date - 120 Then
            wsI.Range("B" & i & ":G" & i).Copy
            wsO.Cells(j, "B").PasteSpecial Paste:=xlPasteValues
            wsI.Range("B" & i & ":G" & i).ClearContents
        j = j + 1
        End If
        
    Next i
End With

 

[Fluff]

How about

j = wsO.Cells(Rows.Count, "B").End(xlUp).Row[COLOR=#ff0000]+1[/COLOR]

 

[kuldeepnagar]

Thank you Mr. @Fluff. It resolved my first issue. but when condition is met, it is copying data next to last instead of last row and leaving last row empty.

 

[Fluff]

Add the line in blue as shown

LastRow = wsI.Cells(Rows.Count, "G").End(xlUp).Row


j = wsO.Cells(Rows.Count, "B").End(xlUp).Row + 1

[COLOR=#0000ff]MsgBox j[/COLOR]
With wsI

When you run the code, what does the msgbox say?
And is that the correct row to write the information to?

 

[kuldeepnagar]

Hi It shows 11, I had data till row 10 in sheet "Lapsed" but copied data on row 12, leaving 11 as empty.

 

[kuldeepnagar]

Dear Mr. @Fluff. Thank you so much for your time and support. It started working after changing
For i = 3 To LastRow it was i=2 originally.
Kind Regards.

 

[Fluff]

Glad you figured it out & thanks for the feedback

 

[kuldeepnagar]

Dear Mr. Fluff, I am getting one strange issue with above code. It works fine on some times, specially during test. But when I check it on some random day, it eliminate on row from "Lapsed" sheet. I am unable to understand why it is deleting/over writing one row from Lapsed sheet. Request your support in analysing it. My code is as below

[FONT=Verdana]Sub RectangleRoundedCorners4_Click()
ActiveSheet.Unprotect "XXXXXXX"[/FONT]
[FONT=Verdana]Application.ScreenUpdating = False[/FONT]
[FONT=Verdana]Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, i As Long, j As Long
Dim LastColumn As Long, a As Long, b As Long
Dim rng As Range[/FONT]
[FONT=Verdana]Set wsI = Sheets("Active")
Set wsO = Sheets("Lapsed")[/FONT]
[FONT=Verdana]Set rng = wsI.Range("B:G")[/FONT]
[FONT=Verdana]'Last Row in a Column. Row need to start in row 2
LastRow = wsI.Cells(Rows.Count, "G").End(xlUp).Row[/FONT]
[FONT=Verdana]j = wsO.Cells(Rows.Count, "B").End(xlUp).Row + 1[/FONT]
[FONT=Verdana]
With wsI
   'Loop through each row
    For i = 3 To LastRow
        If .Range("H" & i).Value <= Date - 120 Then
            wsI.Range("B" & i & ":G" & i).Copy
            wsO.Cells(j, "B").PasteSpecial Paste:=xlPasteValues
            wsI.Range("B" & i & ":G" & i).ClearContents
        j = j + 1
        End If
        
    Next i
End With
Application.ScreenUpdating = True[/FONT]
[FONT=Verdana]
Range("A4:AZ153").Sort key1:=Range("H4:H153"), _
order1:=xlAscending, Header:=xlNo
Range("A202:AZ251").Sort key1:=Range("H202:H251"), _
order1:=xlAscending, Header:=xlNo
Range("A253:AZ302").Sort key1:=Range("H253:H302"), _
order1:=xlAscending, Header:=xlNo
ActiveSheet.Protect "XXXXXXX", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
'ActivateSheet.Sheets("Lapsed") = True
Sheets("Lapsed").Select
ActiveSheet.Unprotect "XXXXXXXX"
Range("B3:AZ153").Sort key1:=Range("G3:G153"), _
order1:=xlAscending, Header:=xlNo
ActiveSheet.Protect "XXXXXXXX"
End Sub
[/FONT]

 

[Fluff]

The only thing I can think of, is that if column B won't always have a value.