Save me from pulling out my hair! (VBA Coding)

[Complaints Department]

Hey all,

I am losing my mind trying to figure this out and after hours of searching online, I couldn't find anything to help.

I need to create a running list for current project statuses. There are two sheets in the document, OUTSTANDING and COMPLETED.

On the OUTSTANDING sheet shown below, I have the subsequent VBA code for when I select "YES" in column D in the relevant row, it will do the following:

• Move that row to the bottom of the list
• Strikethrough the data in that row

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim tbl As ListObject, wRow As Long
  Set tbl = ActiveSheet.ListObjects("Table1")
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, tbl.ListColumns("COMPLETED").Range) Is Nothing Then
    If UCase(Target.Value) = "YES" Then
      Application.ScreenUpdating = False
      wRow = Target.Row - tbl.HeaderRowRange.Row
      tbl.ListRows.Add AlwaysInsert:=True
      tbl.DataBodyRange.Rows(wRow).Font.Strikethrough = True
      tbl.DataBodyRange.Rows(wRow).Copy tbl.DataBodyRange.Rows(tbl.ListRows.Count)
      tbl.ListRows(wRow).Delete
          End If
  End If
End Sub

However, instead of moving this row to the bottom of this same list, I need the following:

• Selecting "YES" will move the row from sheet OUTSTANDING to the top of the list on sheet COMPLETED (see below image for reference)
• Strikethrough the data in that row
• Add in today's date to column E (the date of when "YES" was selected)
• When another row is moved from sheet OUTSTANDING, it will add the new row to the top of the list, and move all other rows down so that the most recent move will remain at the top

I'd appreciate it if anyone was able to assist!

Thank you in advance!!

 

[mikenelena]

Give this a try. I re-created your worksheets and table structure, and it seems to work. Good luck! Let me know if you get it to work for you.

Private Sub Worksheet_Change(ByVal Target As Range)
  
Dim tbl As ListObject, wRow As Long
Set tbl = ActiveSheet.ListObjects("Table1")
  
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, tbl.ListColumns("COMPLETED").Range) Is Nothing Then
    If UCase(Target.Value) = "YES" Then
      Application.ScreenUpdating = False
      wRow = Target.Row - tbl.HeaderRowRange.Row
      Sheets("Completed").Range("A2").EntireRow.Insert
      tbl.DataBodyRange.Rows(wRow).Copy Sheets("Completed").Range("A2")
      Sheets("Completed").Range("E2").Value = Now
      Sheets("Completed").Range("A2").EntireRow.Font.Strikethrough = True
      tbl.ListRows(wRow).Delete
    End If
  End If
End Sub

 

[Complaints Department]

Give this a try. I re-created your worksheets and table structure, and it seems to work. Good luck! Let me know if you get it to work for you.

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim tbl As ListObject, wRow As Long
Set tbl = ActiveSheet.ListObjects("Table1")
 
  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, tbl.ListColumns("COMPLETED").Range) Is Nothing Then
    If UCase(Target.Value) = "YES" Then
      Application.ScreenUpdating = False
      wRow = Target.Row - tbl.HeaderRowRange.Row
      Sheets("Completed").Range("A2").EntireRow.Insert
      tbl.DataBodyRange.Rows(wRow).Copy Sheets("Completed").Range("A2")
      Sheets("Completed").Range("E2").Value = Now
      Sheets("Completed").Range("A2").EntireRow.Font.Strikethrough = True
      tbl.ListRows(wRow).Delete
    End If
  End If
End Sub

Amazing it's working, thank you!

I've noticed a few things that I was hoping you could help with.

• When the row moves from the first sheet (OUTSTANDING), the whole row is deleted and the table keeps shrinking. Could you make it so that it will add another row to the bottom of the table?
• Once the row is moved to the second sheet (COMPLETED), the date in column E is picking up the formatting of the table header. Can this be fixed (see below image):

 

[mikenelena]

Here you go. This should get you where you want to be:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim tbl As ListObject, wRow As Long
Set tbl = ActiveSheet.ListObjects("Table1")

  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, tbl.ListColumns("COMPLETED").Range) Is Nothing Then
    If UCase(Target.Value) = "YES" Then
      Application.ScreenUpdating = False
      wRow = Target.Row - tbl.HeaderRowRange.Row
      Sheets("Completed").Range("A2").EntireRow.Insert
      tbl.DataBodyRange.Rows(wRow).Copy Sheets("Completed").Range("A2")
      Sheets("Completed").Range("E2").Value = Now
      Sheets("Completed").Range("A2").EntireRow.Font.Strikethrough = True
      Sheets("Completed").Range("E2").Value = Format(Now(), "dd-mm-yyyy")
      tbl.ListRows(wRow).Delete
      tbl.ListRows.Add
    End If
  End If
End Sub

 

[Complaints Department]

Here you go. This should get you where you want to be:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim tbl As ListObject, wRow As Long
Set tbl = ActiveSheet.ListObjects("Table1")

  If Target.CountLarge > 1 Then Exit Sub
  If Not Intersect(Target, tbl.ListColumns("COMPLETED").Range) Is Nothing Then
    If UCase(Target.Value) = "YES" Then
      Application.ScreenUpdating = False
      wRow = Target.Row - tbl.HeaderRowRange.Row
      Sheets("Completed").Range("A2").EntireRow.Insert
      tbl.DataBodyRange.Rows(wRow).Copy Sheets("Completed").Range("A2")
      Sheets("Completed").Range("E2").Value = Now
      Sheets("Completed").Range("A2").EntireRow.Font.Strikethrough = True
      Sheets("Completed").Range("E2").Value = Format(Now(), "dd-mm-yyyy")
      tbl.ListRows(wRow).Delete
      tbl.ListRows.Add
    End If
  End If
End Sub

You are the best. Thank you so much for your help!!!!

 

[mikenelena]

Please mark your issue as solved so it will be removed from the Unsolved list. Thanks!

 

[Rtrip9]

I need a similar code. I made a another post about. Please help