Delete Rows except rows with specific values across multiple uniquely named Worksheets

Good afternoon. I'm in the final stages of building a workbook that will synthesize a huge amount of data from a CSV file into a usable format. I realize my code is not very elegant but I'm using the limited skills I have to attempt this time saving workbook.

After I call all of the macros in the workbook, I need one last macro to loop through all worksheets and delete specific rows based on the data contained in column D titled "Team" in each worksheet. For instance:

• In Worksheet "Non-Billable", I need to delete all rows that have data in column D leaving only the rows that have no data in column D.
• In Worksheet "Bangor", I need to delete all rows that have data in column D leaving only the rows that have "Bgr1", "BgrO" or "Mac" in column D.
• In Worksheet "Dover-Foxcroft", I need to delete all rows that have data in column D leaving only the rows that have "Dov" or "DovO" in column D.
• In Worksheet "Wilton", I need to delete all rows that have data in column D leaving only the rows that have "Far", "FarO" or "FarC" in column D.
• In Worksheet "Presque Isle", I need to delete all rows that have data in column D leaving only the rows that have "Pqi" in column D.
• In Worksheet "Waterville", I need to delete all rows that have data in column D leaving only the rows that have "WtvO" in column D.

I've attached the workbook and the code I'm using is pasted below.

Sub CreateCurrentOmit()
Call ChangeWorksheetName
Call DeleteColumns
Call MoveColumnI
Call HeadersandFormatting
Call SORT
Call FreezeTopRow
Call CopyWorksheet
Call RenameWorksheets

End Sub

Sub ChangeWorksheetName()

    ActiveSheet.Name = "Non-Billable"

End Sub

Sub DeleteColumns()

    Application.EnableEvents = False    '<---------Added line of Code to make "refresh" less choppy"
    Application.ScreenUpdating = False  '<---------Added line of Code to make "refresh" less choppy"
    
    Range("A:AH,AJ:AM,AO:AR,AT:AV,AZ:BA,BC:BC,BE:BK,BM:DL").Select
    Range("A1").Activate
    Selection.Delete shift:=xlToLeft

    Application.ScreenUpdating = True   '<---------Added line of Code to make "refresh" less choppy"
    Application.EnableEvents = True     '<---------Added line of Code to make "refresh" less choppy"

End Sub
Sub MoveColumnI()

    Application.EnableEvents = False    '<---------Added line of Code to make "refresh" less choppy"
    Application.ScreenUpdating = False  '<---------Added line of Code to make "refresh" less choppy"
    
    Columns("I:I").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert shift:=xlToRight
    
    Application.ScreenUpdating = True   '<---------Added line of Code to make "refresh" less choppy"
    Application.EnableEvents = True     '<---------Added line of Code to make "refresh" less choppy"
    
End Sub

Sub SORT()
    
    Dim oneRange As Range
    Dim aCell As Range

    Set oneRange = Range("A1:I2000")
    Set aCell = Range("D1")

    oneRange.SORT Key1:=aCell, Order1:=xlAscending, Header:=xlYes
    
End Sub

Sub HeadersandFormatting()
Dim wbI As Workbook
Dim wsI As Worksheet
Dim LR As Long

Set wbI = ThisWorkbook                          'Source/Input Workbook
Set wsI = wbI.Sheets("Non-Billable")       'Set the relevant sheet from where you want to copy

With wsI
    wsI.Range("A1").CurrentRegion.Copy .Range("A1")      'Paste it in say Cell A1. Change as applicable
    Rows(1).Insert shift:=xlShiftDown
    
    .Range("A1:J1").Value = [{"Worker","Client", "Scheduled as", "Team", "Date", "Time In", "Time Out", "Total Time", "Rate", "Comments"}]
    .Rows("1:1").Font.Bold = True                   'Bold top row
    
    .Range("C:J").HorizontalAlignment = xlCenter    'formatting
    .Columns("A:E").AutoFit
    .Columns("F").ColumnWidth = 15
    .Columns("G").ColumnWidth = 15
    .Columns("H").ColumnWidth = 10
    .Columns("I").ColumnWidth = 10
    .Columns("J").ColumnWidth = 60
    .Columns("A:J").Font.Color = vbBlack
    .Columns("A:J").Font.Size = 11
    .Columns("A:J").Font.Name = "Times New Roman"
   
   
End With

End Sub
Sub FreezeTopRow()

    Rows("1:1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    Selection.Font.Bold = True
    Range("A1:H1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub


Sub CopyWorksheet()
   Dim x As Integer
   
   x = InputBox("Enter number of times to copy active sheet")
   For numtimes = 1 To x
      'Loop by using x as the index number to make x number copies.
      ActiveWorkbook.ActiveSheet.Copy _
         After:=ActiveWorkbook.Sheets("Non-Billable")
         'Put copies after.
         'Replace "Sheet1" with sheet name that you want.
   Next
End Sub

Sub RenameWorksheets()

    Sheets("Non-Billable (6)").Select
    Sheets("Non-Billable (6)").Name = "Bangor"
    
    Sheets("Non-Billable (5)").Select
    Sheets("Non-Billable (5)").Name = "Dover-Foxcroft"
    
    Sheets("Non-Billable (4)").Select
    Sheets("Non-Billable (4)").Name = "Presque Isle"
    
    Sheets("Non-Billable (3)").Select
    Sheets("Non-Billable (3)").Name = "Waterville"
    
    Sheets("Non-Billable (2)").Select
    Sheets("Non-Billable (2)").Name = "Wilton"

End Sub

Current Omit (template).xlsm

Thanks.

Matthew

Thanks for providing feedback. I've implemented your suggested code and I keep running into difficulties. I need to run the code a few more times to have a better sense of what's going wrong. I'll be in touch. Thanks.

Matthew

I've attached the workbook with you code installed. The code doesn't appear to be working as expected. I've run your code several times in the attached workbook and it appears to be deleting rows that should remain and not deleting rows that should be deleted. I'll keep working on it tomorrow. Any thoughts you might have would be appreciated. Thanks.

Matthew


Current Omit (template).xlsm

Okay, so I've amended the code with the above suggested changes and it's working great with one exception.

1) The rows containing no value in Column D are not deleting on Worksheets Bangor, Dover-Foxcroft, Presque Isle, Waterville and Wilton after the code is run.

Here's the code as it sits in the workbook now:

Sub Delete_Rows_ColumnD()
Dim arr As Variant
Dim i As Integer
Dim j As Long

Application.ScreenUpdating = False

arr = Array("Non-Billable", "Bangor", "Dover-Foxcroft", "Wilton", "Presque Isle", "Waterville")

For i = LBound(arr) To UBound(arr)
    Select Case i
        Case 0
            With Sheets(arr(i))
                .AutoFilterMode = False
                .Range("D1:D" & .Range("D" & Rows.Count).End(xlUp).Row).AutoFilter 1, "<>"
                .Range("D2:D" & .Range("D" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                .AutoFilterMode = False
            End With
        Case 1
            '"Bgr1", "BgrO" or "Mac"
            For j = Sheets(arr(i)).Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
                If Sheets(arr(i)).Range("D" & j).Value = "Bgr1" Or Sheets(arr(i)).Range("D" & j).Value = "Bgr0" Or Sheets(arr(i)).Range("D" & j).Value = "Mac" Then
                Else
                    Sheets(arr(i)).Range("A" & j).EntireRow.Delete
                End If
            Next j
        Case 2
            '"Dov"or "DovO"
            For j = Sheets(arr(i)).Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
                If Sheets(arr(i)).Range("D" & j).Value = "Dov" Or Sheets(arr(i)).Range("D" & j).Value = "DovO" Then
                Else
                    Sheets(arr(i)).Range("A" & j).EntireRow.Delete
                End If
            Next j
        Case 3
            '"Far", "FarO" or "FarC"
            For j = Sheets(arr(i)).Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
                If Sheets(arr(i)).Range("D" & j).Value = "Far" Or Sheets(arr(i)).Range("D" & j).Value = "Far0" Or Sheets(arr(i)).Range("D" & j).Value = "FarC" Then
                Else
                    Sheets(arr(i)).Range("A" & j).EntireRow.Delete
                End If
            Next j
        Case 4
            '"Pqi" or "PqiO"
            For j = Sheets(arr(i)).Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
                If Sheets(arr(i)).Range("D" & j).Value = "Pqi" Or Sheets(arr(i)).Range("D" & j).Value = "PqiO" Then
                Else
                    Sheets(arr(i)).Range("A" & j).EntireRow.Delete
                End If
            Next j
        Case 5
            '"Wtv" or "WtvO"
            For j = Sheets(arr(i)).Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
                If Sheets(arr(i)).Range("D" & j).Value = "Wtv" Or Sheets(arr(i)).Range("D" & j).Value = "WtvO" Then
                Else
                    Sheets(arr(i)).Range("A" & j).EntireRow.Delete
                End If

            Next j

End Select

Application.ScreenUpdating = True

Next i

End Sub

I've attached the most current version of the workbook below. Thanks.

Current Omit (template).xlsm

Thank you for your help. It works like a charm. Now to try my hand at speeding up the code.

Matthew