small adjustment for this macro

[M3L333]

Can someone please help me to make a small adjustment to this macro?

When creating a new row at the top on Sheet "Discharges", and moving the current information down, the Discharges sheet is currently only moving down rows B-P. Once the data is transferred to the discharges sheet there is some extra data inputted into several columns to the rights. I want all data in the row to be moved down together so that the data does not get mixed up.

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 P for 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

 

[James006]

Hello,

You could test the following

Private Sub CommandButton1_Click()
Dim lrow As Long
Dim lcol As Long
Dim r As Long


Application.ScreenUpdating = False


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


'Find lcol  - Last Column  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
lcol = Sheets("Bed Registry").ActiveSheet.Cells(1, Application.Columns.Count).End(xlToLeft).Column


'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
      '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, lcol)).Copy Sheets("Discharges").Cells(2, "B")
      'Clear columns B-P on Bed Registry
      Sheets("Bed Registry").Range(Cells(r, "B"), Cells(r, lcol)).ClearContents
    End If
  Next r
End Sub

Have to assume the Number of Columns will keep on changing ...

Otherwise ... you could have replaced the Letter P by the Letter of your last Column ... :wink:

 

[M3L333]

I tried this and it is not working, trying to figure out the issue, but not sure why it won't work.