Delete and Move Rows That Do Not Meet onditions

[cr2289]

A worksheet has columns A:AA. In column M (column 13) there are codes. Let's say the codes follow the alphabet: AAA, BBB, CCC through ZZZ. I would like to delete the rows with column M values that are not AAA, FFF, GGG, and RRR. Then, from the remaining rows, the code AAA rows need to move to new sheet tab 2. The code RRR rows should move to new sheet tab 3. Code FFF and GGG rows remain on the original sheet tab. Help with the VBA please. Thank you so much.

Sorry about misspelling "Conditions". I couldn't edit the title.

 

[Herakles]

This assumes that you only have one sheet in your workbook. Let me know if this is not the case before you run the code.

It creates a new sheet for the rows with AAA and RRR.

It deletes all rows from sheet 1 that do not have a value of FFF or GGG in column 13.

The sub routines are reuseable.

Run subMain on a copy of your data to test it.

Private Sub subMain()
   
    Call subDeleteSheets
   
    Call subCopyRowsToNewSheet("AAA", "")
   
    Call subCopyRowsToNewSheet("RRR", "")
   
    Call subDeleteRowsBasedUponValue(Worksheets(1), Worksheets(1).Cells(1, 13).Value, "FFF,GGG", True)
   
    MsgBox "Rows deleted and moved.", vbOKOnly, "Confirmation"
   
End Sub

Private Sub subDeleteSheets()
Dim i As Integer
Dim Ws As Worksheet
   
    Worksheets(1).Activate
   
    Application.DisplayAlerts = False
   
    For Each Ws In ActiveWorkbook.Worksheets
        If Ws.Index <> 1 Then
            Ws.Delete
        End If
    Next Ws
   
    Application.DisplayAlerts = True
   
End Sub

Public Sub subCopyRowsToNewSheet(strCriteria As String, strSheetName As String)

    Application.ScreenUpdating = False
   
    Worksheets.Add after:=Worksheets(Worksheets.Count)
   
    If strSheetName <> "" Then
        ActiveSheet.Name = strSheetName
    End If
   
    With Worksheets(1)
           
        .AutoFilterMode = False
       
        With .Range("A1").CurrentRegion
            .AutoFilter 13, strCriteria
            On Error Resume Next
            .EntireRow.Copy ActiveSheet.Range("A1")
            On Error GoTo 0
        End With
       
        .AutoFilterMode = False
       
    End With
   
    With Worksheets(Worksheets.Count)
        .Cells.EntireColumn.AutoFit
    End With
   
     Application.ScreenUpdating = True
       
End Sub

Public Sub subDeleteRowsBasedUponValue(Ws As Worksheet, strColumn As String, strValues As String, blnKeep As Boolean)
Dim lngRow As Long
Dim lngRows As Long
Dim rngfound As Range

    With Ws
   
        Set rngfound = Ws.Rows(1).Find(strColumn, LookIn:=xlValues)
       
        If rngfound Is Nothing Then
          Exit Sub
        End If
       
        lngRows = .Range("A" & Rows.Count).End(xlUp).Row
                    
        For lngRow = lngRows To 2 Step -1
       
            ' Delete if not in list and just keep list items.
            If blnKeep Then
                If (InStr(1, strValues, .Cells(lngRow, rngfound.Column), vbTextCompare) = 0) Then
                    .Cells(lngRow, 1).EntireRow.Delete
                End If
            End If
           
              ' Delete if in list and not keep list items.
            If Not blnKeep Then
                If (InStr(1, strValues, .Cells(lngRow, rngfound.Column), vbTextCompare) > 0) Then
                    .Cells(lngRow, 1).EntireRow.Delete
                End If
            End If
           
        Next lngRow
         
  End With
 
End Sub

 

[cr2289]

Yes! Yes! Saves us a lot of time. Thank you!