Keep only certain rows

[jassybun]

the code below works great with deleting columns not needed - but I also want to delete rows, and keep only ones where the Work Activity equals "76", "77", "82" or "85"


Instructions: https://chandoo.org/forum/threads/posting-a-sample-workbook.451/

Sub DeleteColumnsRows()

  Dim Sht2 As Worksheet, Sht3 As Worksheet
  Dim Dict As Object, Cell As Range
  Dim Dict2 As Object, Cell2 As Range
  Dim RngToDelete As Range

  Set Sht2 = ThisWorkbook.Sheets("Sheet1") 'Modify accordingly.
  Set Sht3 = ThisWorkbook.Sheets("Sheet2") 'Modify accordingly.

  Application.ScreenUpdating = False

  With Sht2

  For Each Cell In .Rows(1).Cells
  If InStr(1, Cell.Value, "PPE Date") = 0 And InStr(1, Cell.Value, "Work Center") = 0 And InStr(1, Cell.Value, "Name") = 0 And InStr(1, Cell.Value, "Work Activity") = 0 And InStr(1, Cell.Value, "Operation") = 0 Then
  If Not RngToDelete Is Nothing Then
  Set RngToDelete = Union(RngToDelete, .Columns(Cell.Column))
  Else
  Set RngToDelete = .Columns(Cell.Column)
  End If
  End If
  Next Cell
  RngToDelete.Delete


  Application.ScreenUpdating = True
End With
End Sub

 

[jassybun]

I am attaching a file that has sample info and the macro is in the module

 

[Fluff13]

How about

Sub jassybun()
  Dim Nc As Long, Lr As Long
  Dim Ws As Worksheet
 
  With Sheets("Sheet1")
      Nc = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
      Lr = .Range("A" & Rows.Count).End(xlUp).Row
      With .Range(.Cells(1, Nc), .Cells(Lr, Nc))
        .Value = Evaluate(Replace("If((@=76)+(@=77)+(@=82)+(@=85),true,"""")", "@", .Offset(, -1).Address))
      End With
      .Range("A1", .Cells(Lr, Nc)).AutoFilter Nc, ""
      .AutoFilter.Range.Offset(1).EntireRow.Delete
      .AutoFilterMode = False
      .Columns(Nc).ClearContents
  End With
End Sub

This assumes that the Activity column is the last column

 

[jassybun]

perfecto - thank you!

 

[Fluff13]

You're welcome & thanks for the feedback