My VBA code to delete rows works, but it is too slow

I have a VBA code that splits a large master file into several smaller sub-files, with each sub-file containing a portion of the original data. After splitting, the code is supposed to delete unwanted rows based on specific criteria.

The code runs correctly and performs the task as expected. However, it takes nearly an hour to complete the process. I'm concerned about the time it takes and would like to know if this is normal, or if there is a more efficient method for deleting rows that could speed up the code execution.

Is there an alternative approach I could use to delete rows faster, and if so, what changes can I make to optimize the performance of my VBA code?

Sub Bud_Split()

' Start timer
startTime = Timer
Application.ScreenUpdating = False
    Dim originalFile As String
    originalFile = Application.GetOpenFilename(Title:="Select the original Excel file")
    If originalFile = "" Then Exit Sub ' User canceled the selection

    Dim directoryPath As String
    directoryPath = Left(originalFile, InStrRev(originalFile, "\"))

    Dim newNames() As Variant
    newNames = Array("Ashwin.xlsx", "Avnish.xlsx", "Bernardo.xlsx", "Candice.xlsx", "Cheryl.xlsx", "Facilities.xlsx", "Gautam.xlsx", "Gerald.xlsx", "Guavus.xlsx", "Keith.xlsx", "Li.xlsx", "Miguel.xlsx", "Mike.xlsx", "Nitesh.xlsx", "Peter.xlsx", "Robert.xlsx", "Raja.xlsx", "Renato.xlsx", "Ripu.xlsx", "Rui.xlsx", "Sheila.xlsx") ' Specify your desired names

    ' Copy the original file the desired number of times
    Dim i As Long
    For i = 0 To UBound(newNames)
        FileCopy originalFile, directoryPath & newNames(i)
    Next i

   Kill originalFile
   
    ' Process each copied file
    Dim file As Object
    For Each file In CreateObject("Scripting.FileSystemObject").GetFolder(directoryPath).Files
        If file.Name Like "*.xlsx" Or file.Name Like "*.xlsb" Then
            ProcessWorkbook file.Path
        End If
    Next file

Application.ScreenUpdating = True

' End timer
endTime = Timer

' Calculate elapsed time in seconds
elapsedTime = Round(endTime - startTime, 0)

' Extract hours, minutes, and seconds
hours = elapsedTime \ 3600
minutes = (elapsedTime Mod 3600) \ 60
seconds = elapsedTime Mod 60

' Format output string in HH:MM:SS format
timeString = Format(hours, "00") & ":" & Format(minutes, "00") & ":" & Format(seconds, "00")

' Display the result in a message box (optional)
MsgBox "Execution time: " & timeString, vbInformation

End Sub



Sub ProcessWorkbook(workbookPath As String)

    Dim wb As Workbook
    Set wb = Workbooks.Open(workbookPath)

    ' Update cell B6 with filename without extension
    Dim targetSheetName As String
    targetSheetName = "Overall"

    Dim targetSheet As Worksheet
    Set targetSheet = wb.Sheets(targetSheetName)

    If targetSheet Is Nothing Then
        MsgBox "Sheet '" & targetSheetName & "' not found in file.", vbExclamation
    Else
        Dim fileBaseName As String
        fileBaseName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
        targetSheet.Range("B6").Value = fileBaseName
    End If

Dim sheetNames As Variant
    sheetNames = Array("HC by CC", "Budget HC", "HC Investments Summary", "HC Investments", "Non-HC Investments", "Cost - Planful", "Lookup")

    Dim sheetName As Variant
    For Each sheetName In sheetNames
        DeleteRowsByCriteria wb.Sheets(sheetName), 1, "Delete" ' Delete rows in column A
    Next sheetName

    DeleteTableRowsByCriteria wb.Sheets("Lookup"), "Lookup", 3, "Delete" ' Delete table rows in column C

wb.Sheets("Overall").Activate
wb.Sheets("Overall").Range("A1").Activate

    wb.Close SaveChanges:=True

End Sub



Sub DeleteRowsByCriteria(ws As Worksheet, columnIndex As Long, criteria As Variant)

    Application.Calculation = xlCalculationManual

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, columnIndex).End(xlUp).row

    Dim deleteRange As Range
    Dim currentCell As Range

    For Each currentCell In ws.Range("A1:A" & lastRow).Cells
        If currentCell.Value = criteria Then
            If deleteRange Is Nothing Then
                Set deleteRange = currentCell
            Else
                Set deleteRange = Union(deleteRange, currentCell)
            End If
        End If
    Next currentCell

    If Not deleteRange Is Nothing Then
        deleteRange.EntireRow.Delete
    End If

    Application.Calculation = xlCalculationAutomatic
End Sub




Sub DeleteTableRowsByCriteria(ws As Worksheet, tableName As String, columnIndex As Long, criteria As Variant)

    Dim tbl As ListObject
    Set tbl = ws.ListObjects(tableName)

    If Not tbl Is Nothing Then
        Dim i As Long
        For i = tbl.ListRows.Count To 1 Step -1
            If tbl.ListRows(i).Range.Cells(1, columnIndex).Value = criteria Then
                tbl.ListRows(i).Delete
            End If
        Next i
    End If

End Sub

'Sub HideSheets(wb As Workbook, sheetNames As Variant)
'    Dim i As Long
'
'    For i = LBound(sheetNames) To UBound(sheetNames)
'        wb.Sheets(sheetNames(i)).Visible = xlSheetHidden
'    Next i
'End Sub

I know that deleting rows takes time, be it done manually or with the help of VBA. But I've tried searching for an alternate way of handling it and couldn't find any.