re-work this macro (create new row)

[M3L333]

Instead of "find next row to paste to on Discharges", how could I have this macro create a new row between row 1 & 2 to paste to information there. This way, my most current information would always be on top.

Private Sub CommandButton1_Click()

Dim lr As Long
Dim r As Long
Dim nr As Long

Application.ScreenUpdating = False

' Find last row in column P with data on Bed Registry
lr = Sheets("Bed Registry").Cells(Rows.Count, "P").End(xlUp).Row

' Loop through all rows on Bed Registry and check column P for closed
For r = 2 To lr
If Sheets("Bed Registry").Cells(r, "P") = "CLOSED" Then
' Find next row to paste to on Discharges
nr = Sheets("Discharges").Cells(Rows.Count, "P").End(xlUp).Row + 1
' Copy columns B-P to Discharges
Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).Copy Sheets("Discharges").Cells(nr, "B")
' Clear columns B-P on Bed Registry
Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).ClearContents
End If
Next r

Application.ScreenUpdating = True

End Sub

 

[Joe4]

It looks like you are commenting out necessary lines (not sure why you are doing that).
Does this work?

Private Sub CommandButton1_Click()

Dim lr As Long
Dim r As Long

Application.ScreenUpdating = False

'Find lr column P with data on Bed Registry
lr = Sheets("Bed Registry").Cells(Rows.Count, "P").End(xlUp).Row

'Loop through all rows on Bed Registry and check column Pfor closed
For r = 2 To lr
    If Sheets("Bed Registry").Cells(r, "P") = "CLOSED" Then
        Sheets("Discharges").Activate
        'Insert r at r2
        Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'Copy columns B-P to Discharges on row 2
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).Copy Sheets("Discharges").Cells(2, "B")
        'Clear columns B-P on Bed Registry
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).ClearContents
    End If
Next r

End Sub

 

[Joe4]

It looks like you are commenting out necessary lines (not sure why you are doing that).
Does this work?

Private Sub CommandButton1_Click()

Dim lr As Long
Dim r As Long

Application.ScreenUpdating = False

'Find lr column P with data on Bed Registry
lr = Sheets("Bed Registry").Cells(Rows.Count, "P").End(xlUp).Row

'Loop through all rows on Bed Registry and check column Pfor closed
For r = 2 To lr
    If Sheets("Bed Registry").Cells(r, "P") = "CLOSED" Then
        Sheets("Discharges").Activate
        'Insert r at r2
        Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'Copy columns B-P to Discharges on row 2
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).Copy Sheets("Discharges").Cells(2, "B")
        'Clear columns B-P on Bed Registry
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).ClearContents
    End If
Next r

Application.ScreenUpdating = True

End Sub

 

[M3L333]

Thanks, but this is not working. The information is not transferring and rows are now being created on both worksheets.

 

[Joe4]

OK, I recreated the whole scenario, and it looks like it wanted one more "Activate" line.
This worked for me:

Private Sub CommandButton1_Click()

Dim lr As Long
Dim r As Long

Application.ScreenUpdating = False

'Find lr column P with data on Bed Registry
lr = Sheets("Bed Registry").Cells(Rows.Count, "P").End(xlUp).Row

'Loop through all rows on Bed Registry and check column Pfor closed
For r = 2 To lr
    If Sheets("Bed Registry").Cells(r, "P") = "CLOSED" Then
        Sheets("Discharges").Activate
        'Insert r at r2
        Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'Copy columns B-P to Discharges on row 2
        Sheets("Bed Registry").Activate
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).Copy Sheets("Discharges").Cells(2, "B")
        'Clear columns B-P on Bed Registry
        Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, "P")).ClearContents
    End If
Next r

End Sub