Create Table After Deleting Rows Before Desired Range and Filter to Delete All Other Unnecessary Rows

Question

The code below first searches for the first searchText and deletes all rows that precede it to establish a range for a table object. Once the table object is created, it's filtered by unnecessary fields. After ensuring the searchText is in the first row (header), it deletes all visible rows below it in order to keep all rows with a date in the first column. The rest of the code fixes a lot of weird formatting issues. The FindLast function just returns the last used cell in order to establish the end of the range.

Because I'm assuming that the filter criteria will remain the same, it's a bit dangerous. I assume it would be better to filter by only rows with dates and delete all invisible rows, though I'm not sure what would be the best way to go about this.

Sub Reformat_AP_PYMT()

    Const expectedShtName As String = "ZZ_AP_PYMT"
    Const searchText As String = "Accounting Date"
    Const searchText2 As String = "Voucher Id"
    Const searchText3 As String = "Vendor Id"
    Const searchText4 As String = "Merchandise"
    
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim rng As Range
    Dim searchCell As Range
    Dim lastCell As String
    
    'Check is worksheet name exists
    On Error Resume Next
    Set ws = GetWorksheetByName(expectedShtName, ActiveWorkbook)
    On Error GoTo 0
    
    If ws Is Nothing Then
        'If it doesn't exist, set to first sheet name
        Set ws = GetUpdatedName(ActiveWorkbook)
        If ws Is Nothing Then
            'If all else fails, ask user to change sheet name
            MsgBox "Please change sheet (tab) name to ZZ_AP_PYMT", vbExclamation, "Cancelled"
            Exit Sub
        End If
    End If
    
    Dim app As New ExcelAppState: app.Sleep: app.StoreState
    Call DeleteBegRows(searchText, ws)
    
    'Set range by calling FindLast (cell) and create table object
    On Error Resume Next
    lastCell = FindLastRowColCel.FindLast(3)
    Set rng = ws.Range("A1", lastCell)
    Set tbl = ws.ListObjects.Add(xlSrcRange, rng, , xlYes)
    
    'Filter first field of table by unnecessary fields
    'Only need the rows that have dates in first column and first row with accounting date in first column for header
    'The issue is that this assumes these field criteria will not change. It may be better to search for Accounting date in first row _
        create table, filter by date values, and delete all invisible rows
    tbl.Range.AutoFilter Field:=1, Criteria1:= _
        Array( _
        "End of Report" _
        , "Business Name" _
        , "Unit" _
        , "Payment Method" _
        , "Grand total" _
        , "Report ID" _
        , "Subtotal" _
        , "Accounting Date" _
        , "="), Operator:= _
        xlFilterValues
    On Error GoTo 0
    
    'Search for searchText (Accounting Date) in table headers
    On Error Resume Next
    Set searchCell = tbl.HeaderRowRange.Find(searchText, _
        LookAt:=xlWhole)
    On Error GoTo 0
    If searchCell.Row <> 1 Then
        MsgBox "Incorrect Headers. Ensure there are no rows above the first Accounting Date field.", vbInformation, "Row deletion skipped."
        Err.Clear
        app.RestoreState
        Exit Sub
    Else
        ws.Rows(2 & ":" & ws.Rows.Count).Delete
    End If
    
    On Error Resume Next
    tbl.Range.AutoFilter Field:=1
    If Err.Number <> 0 Then
        MsgBox "Please clear table filters.", vbExclamation, "Failed"
        Err.Clear
        app.RestoreState
        Exit Sub
    End If
    On Error GoTo 0
    
    Call NumberFormat(searchText2, searchText3, tbl)
    Call UnicodeCleanup(tbl)
    Call UpdateMerchAmt(searchText4, tbl)
    
    On Error Resume Next
    tbl.Unlist
    If Err.Number <> 0 Then
        MsgBox "Please convert table to a range.", vbExclamation, "Failed"
        Err.Clear
        app.RestoreState
        Exit Sub
    End If
    On Error GoTo 0
    
    app.RestoreState
    
End Sub

Public Function GetWorksheetByName(ByVal wsName As String, ByVal book As Workbook) As Worksheet
    
    On Error Resume Next
    Set GetWorksheetByName = book.Worksheets(wsName)
    On Error GoTo 0
    
End Function

Public Function GetUpdatedName(ByVal actBook As Workbook) As Worksheet
    
    On Error Resume Next
    Set GetUpdatedName = actBook.Worksheets(1)
    On Error GoTo 0
    
End Function

Public Sub DeleteBegRows(ByVal text As String, ByVal ws As Worksheet)

    Dim textRng As Range
    
    With ws
        On Error Resume Next
        Set textRng = .Cells.Find(What:=text, _
        LookAt:=xlWhole)
        On Error GoTo 0
    
        If Not textRng Is Nothing Then
            If textRng.Row <> 1 Then
                Range("A1", textRng.Offset(-1)).EntireRow.Delete
            Else
                MsgBox "Specified text (" & text & ") is already in the first row.", vbInformation, "Cancelled"
            End If
        Else
            MsgBox ("Specified text (" & text & ") not found.")
        End If
    End With
    
End Sub

Sub NumberFormat(ByVal venID As String, ByVal vouchID As String, ByVal tbl As ListObject)
    
    Dim foundCell As Range
    Dim foundCell2 As Range
    Dim rng As ListColumn
    Dim rng2 As ListColumn
    
    'Attempt to find string values in table header row
    On Error Resume Next
    Set foundCell = tbl.HeaderRowRange.Find(venID, _
        LookAt:=xlWhole)
    Set foundCell2 = tbl.HeaderRowRange.Find(vouchID, _
        LookAt:=xlWhole)
    Set rng = tbl.ListColumns(venID)
    Set rng2 = tbl.ListColumns(vouchID)
    On Error GoTo 0
    
    'Return table header number for specified value
    'Reformat Vendor Id column with 10 zeros & Voucher Id with 8 zeros
    If foundCell Is Nothing Then
        MsgBox "Value not found."
    Else
        rng.Range.NumberFormat = "0000000000"
    End If
    
    If foundCell2 Is Nothing Then
        MsgBox "Value not found."
    Else
        rng2.Range.NumberFormat = "00000000"
    End If
    
End Sub

Sub UnicodeCleanup(ByVal tbl As ListObject)

    Dim i As Long
    Dim varray As Variant
    Dim isEmpty As Boolean
    
    'Create array list from table
    On Error Resume Next
    varray = tbl.DataBodyRange
    On Error GoTo 0
    
    'Check is worksheet name exists
    On Error Resume Next
    isEmpty = IsArrayEmpty(varray)
    On Error GoTo 0
    
    'Replace Unicode with nothing
    If isEmpty = False Then
        For i = LBound(varray) To UBound(varray)
            Cells.Replace What:=ChrW(8237), replacement:="", LookAt:=xlPart
            Cells.Replace What:=ChrW(8236), replacement:="", LookAt:=xlPart
        Next
    Else
        MsgBox "Table range not found.", vbExclamation, "Cancelled"
    End If
    
End Sub

Sub UpdateMerchAmt(ByVal merchAmt As String, ByVal tbl As ListObject)

    Dim mRng As Range
    Dim merchAmtNew As String
    merchAmtNew = "Merchandise Amount"
    
    'Search for Merchandise  Amount in table headers
    On Error Resume Next
    Set mRng = tbl.HeaderRowRange.Find(merchAmt, _
        LookAt:=xlPart)
    On Error GoTo 0
    
    If Not mRng Is Nothing Then
        mRng.Value = merchAmtNew
    Else
        MsgBox "Values not found. Remove space from " & merchAmt, vbExclamation, "Cancelled"
    End If
    
End Sub

Public Function IsArrayEmpty(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayEmpty
' This function tests whether the array is empty (unallocated). Returns TRUE or FALSE.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is really the reverse of IsArrayAllocated.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim LB As Long
    Dim UB As Long
    
    Err.Clear
    On Error Resume Next
    If IsArray(Arr) = False Then
        'We weren't passed an array, return True
        IsArrayEmpty = True
    End If
    
    ' Attempt to get the UBound of the array. If the array is
    ' unallocated, an error will occur.
    UB = UBound(Arr, 1)
    If (Err.Number <> 0) Then
        IsArrayEmpty = True
    Else
        ''''''''''''''''''''''''''''''''''''''''''
        ' On rare occasions, under circumstances I
        ' cannot reliably replicate, Err.Number
        ' will be 0 for an unallocated, empty array.
        ' On these occasions, LBound is 0 and
        ' UBound is -1.
        ' To accommodate this weird behavior, test to
        ' see if LB > UB. If so, the array is not
        ' allocated.
        ''''''''''''''''''''''''''''''''''''''''''
        Err.Clear
        LB = LBound(Arr)
        If LB > UB Then
            IsArrayEmpty = True
        Else
            IsArrayEmpty = False
        End If
    End If
    
End Function

And the ExcelAppState class:

Option Explicit

Private m_calculationMode As XlCalculation
Private m_screenUpdating As Boolean
Private m_displayAlerts As Boolean

Private m_hasStoredState As Boolean
Private m_hasStoredCalcMode As Boolean

Public Sub StoreState()
    With Application
        On Error Resume Next 'In case no Workbook is opened
        m_calculationMode = .Calculation
        m_hasStoredCalcMode = (Err.Number = 0)
        On Error GoTo 0
        m_screenUpdating = .ScreenUpdating
        m_displayAlerts = .DisplayAlerts
    End With
    m_hasStoredState = True
End Sub

Public Sub RestoreState(Optional ByVal maxSecondsToWait As Integer)
    If Not m_hasStoredState Then
        Err.Raise 5, TypeName(Me) & ".RestoreState", "State not stored"
    End If
    With Application
        If m_hasStoredCalcMode Then
            On Error Resume Next
            If .Calculation <> m_calculationMode Then .Calculation = m_calculationMode
            On Error GoTo 0
        End If
        If .ScreenUpdating <> m_screenUpdating Then .ScreenUpdating = m_screenUpdating
        If .DisplayAlerts <> m_displayAlerts Then .DisplayAlerts = m_displayAlerts
    End With
    m_hasStoredState = False
End Sub

Public Sub Sleep()
    With Application
        On Error Resume Next
        If .Calculation <> xlCalculationManual Then .Calculation = xlCalculationManual
        On Error GoTo 0
        If .ScreenUpdating Then .ScreenUpdating = False
        If .DisplayAlerts Then .DisplayAlerts = False
    End With
End Sub

Public Sub Wake(Optional ByVal maxSecondsToWait As Integer = 10)
    With Application
        On Error Resume Next
        If .Calculation <> xlCalculationAutomatic Then .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        If Not .ScreenUpdating Then .ScreenUpdating = True
        If Not .DisplayAlerts Then .DisplayAlerts = True
    End With
End Sub

Answer 1

Getting the desired worksheet

You are using the GetWorksheetByName function which will either return Nothing or a valid worksheet object:

On Error Resume Next
Set ws = GetWorksheetByName(expectedShtName, ActiveWorkbook)
On Error GoTo 0

However, the mentioned function already does the error handling and no error will ever be raised. So, the 3 lines above should be just:

Set ws = GetWorksheetByName(expectedShtName, ActiveWorkbook)

after which you proceed correctly to check If ws Is Nothing Then ....

I like the fact that you've split the logic into multiple functions to make the code more manageable. Let's split even further and move all the logic related with getting the ZZ_AP_PYMT sheet into a separate function to make the main function easier to read/follow:

Private Function GetZZAPPYMTSheet() As Worksheet
    Const expectedShtName As String = "ZZ_AP_PYMT"
    Dim ws As Worksheet
    
    Set ws = GetWorksheetByName(expectedShtName, ActiveWorkbook)
    If ws Is Nothing Then
        'If it doesn't exist, set to first sheet name
        Set ws = GetUpdatedName(ActiveWorkbook)
        If ws Is Nothing Then
            'If all else fails, ask user to change sheet name
            MsgBox "Please change sheet (tab) name to ZZ_AP_PYMT", vbExclamation, "Cancelled"
            Exit Sub
        End If
    End If
End Function

and in the main method we would only need:

Set ws = GetZZAPPYMTSheet()
If ws Is Nothing Then Exit Sub

If we look at the GetUpdateName method:

Public Function GetUpdatedName(ByVal actBook As Workbook) As Worksheet
   On Error Resume Next
   Set GetUpdatedName = actBook.Worksheets(1)
   On Error GoTo 0
End Function

we can see that it simply retrieves the first worksheet of a workbook or returns Nothing if the book is not set or there is no worksheet (e.g. just chart sheets). We could remove this method and instead update the logic inside our GetZZAPPYMTSheet method to take into account that the book might not be set or there are no worksheets, so we can display a more meaningful message to the user:

Private Function GetZZAPPYMTSheet() As Worksheet
    Const expectedShtName As String = "ZZ_AP_PYMT"
    Dim ws As Worksheet
    Dim book As Workbook
    
    Set book = ActiveWorkbook
    If book Is Nothing Then
        'Can happen if this code is run within an AddIn (e.g. .xlam file)
        MsgBox "Please activate a Workbook", vbInformation, "Cancelled"
        Exit Function
    End If
    
    Set ws = GetWorksheetByName(expectedShtName, book)
    If ws Is Nothing Then
        If book.Worksheets.Count > 0 Then
            Set ws = book.Worksheets(1)
        Else
            MsgBox "No Worksheets found!" & vbNewLine & "Please select workbook containing <" _
                & expectedShtName & "> worksheet!", vbInformation, "Cancelled"
            Exit Function
        End If
    End If
    Set GetZZAPPYMTSheet = ws
End Function

Deleting rows

After the desired worksheet is retrieved, your first operation (excluding application state changes) is to delete rows using the DeleteBegRows method. Altough the name of the method suggests that rows are deleted, the method in fact does a text search as well. If the text is not found the method simply displays a message box and returns while the main function continues.

What if the worksheet was entirely empty? The main code will carry on with creating a table (which of course does not get created but simply skipped because of the On Error Resume Next) and eventually an error is raised in between the error handling sections. The state of the application does not get restored because of that.

Because of the above, it is better to remove the 'search text' functionality from the DeleteBegRows method in order to gain some control if the main method should continue or not. This should work:

Private Function FindTextInRange(ByVal text As String, ByVal rng As Range) As Range
    On Error Resume Next
    Set FindTextInRange = rng.Find(What:=text, LookAt:=xlWhole)
    On Error GoTo 0
End Function

which we can call (from Reformat_AP_PYMT) using:

Set rng = FindTextInRange(searchText, ws.UsedRange)
If rng Is Nothing Then
    MsgBox "Cannot find required header!", vbExclamation, "Cancelled"
    Exit Sub
End If

and only then proceed to delete the rows above the found table header. BTW, I would rename searchText with something more meaningful like requiredTableHeader

The method deleting the rows could become:

Public Function DeleteAboveRow(ByVal rowIndex As Long, ByVal ws As Worksheet) As Boolean
    If rowIndex <= 1 Then
        DeleteAboveRow = True
        Exit Function
    End If
    On Error Resume Next
    ws.Rows("1:" & rowIndex - 1).Delete xlShiftUp
    DeleteAboveRow = (Err.Number = 0)
    On Error GoTo 0
End Function

This method will not raise any error but simply return True/False to indicate success. I am not sure if this is critical. Obviously, if the worksheet is protected or the rows are ovelapping with multiple ListObjects the operation will fail so the return value of the function can be used to decide if execution should continue or not.

Code:

Call DeleteBegRows(searchText, ws)

can become:

If Not DeleteAboveRow(rng.Row, ws) Then
    MsgBox "Cannot delete rows!", vbExclamation, "Cancelled"
    app.RestoreState
    Exit Sub
End If

or simply ignoring the result with:

DeleteAboveRow rng.Row, ws

if the delete operation is not absolutely needed.

BTW, you should have posted the ExcelAppState class so that other people understand what it does. I obviously know already from your previous question but keep this in mind. You should strive to post code that can be copied to a new document and actually compiles for all readers. I've edited your question but I am not sure if that will get appoved by the senior members.

Finally, rather than repeating the 2 rows:

app.RestoreState
Exit Sub

we can create a label at the end of the method:

Clean:
    app.RestoreState
End Sub

and replace the 2 mentioned lines with GoTo Clean

Creating the structured table (ListObject)

Since the FindLastRowColCel.FindLast(3) code is missing from your question I will simply be using the Worksheet.UsedRange to create the table. Obviously, this would create issues if the rows above the headers were not deleted but I will simply assume that the delete operation was critical and was not skipped.

This:

On Error Resume Next
lastCell = FindLastRowColCel.FindLast(3)
Set rng = ws.Range("A1", lastCell)
Set tbl = ws.ListObjects.Add(xlSrcRange, rng, , xlYes)

can become:

On Error Resume Next
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.UsedRange, , xlYes)
On Error GoTo 0
If tbl Is Nothing Then
    MsgBox "Cannot create table!", vbExclamation, "Cancelled"
    GoTo Clean
End If

Filtering the table

Instead of filtering specific unwanted values it would be better to simply keep all the dates within the Accounting Date column and delete everything else. It's difficult to maintain a list of possible unwanted values. Your list: Array("End of Report", "Business Name", "Unit", "Payment Method", "Grand total", "Report ID", "Subtotal", "Accounting Date", "=") can never be exhaustive.

We already have the position of the Account Date column in the range we previously searched (i.e. rng). So, the column index would be equal to rng.Column - tbl.Range.Column + 1

If we first sort the table by the dates column, then all the dates will be grouped and we only have to delete above and/or below the dates. No need for filtering. In the final code look for the KeepDatesOnly method to see one way of achieving this. There are many other ways.

Misc

Consider renaming the searchText2, searchText3 and searchText4 to more meaninful constant names.

The tbl.Unlist operation can't really fail if the code reached that far.

I've simplified UnicodeCleanup to just:

Public Sub UnicodeCleanup(ByVal tbl As ListObject)
    If tbl Is Nothing Then Exit Sub
    If tbl.DataBodyRange Is Nothing Then Exit Sub
    With tbl.DataBodyRange
        .Replace What:=ChrW(8237), replacement:="", LookAt:=xlPart
        .Replace What:=ChrW(8236), replacement:="", LookAt:=xlPart
    End With
End Sub

You were running the code for the entire worksheet in a loop. Try entering the following in your Immediate window: ?Cells.Address and then press Enter. You will see what I mean.

The IsArrayEmpty is obviously not needed anymore.

I won't discuss the remaining 2 methods: NumberFormat and UpdateMerchAmt.

Final code

Option Explicit

Sub Reformat_AP_PYMT()
    Const requiredTableHeader As String = "Accounting Date"

    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim rng As Range
    
    'Retrieve required worksheet
    Set ws = GetZZAPPYMTSheet()
    If ws Is Nothing Then Exit Sub
    
    'Find required table header
    Set rng = FindTextInRange(requiredTableHeader, ws.UsedRange)
    If rng Is Nothing Then
        MsgBox "Cannot find required header!", vbExclamation, "Cancelled"
        Exit Sub
    End If
    
    'Delete unnecessary rows
    Dim app As New ExcelAppState: app.Sleep: app.StoreState
    If Not DeleteAboveRow(rng.Row, ws) Then
        MsgBox "Cannot delete rows!", vbExclamation, "Cancelled"
        GoTo Clean
    End If
    
    'Create table
    On Error Resume Next
    Set tbl = ws.ListObjects.Add(xlSrcRange, ws.UsedRange, , xlYes)
    On Error GoTo 0
    If tbl Is Nothing Then
        MsgBox "Cannot create table!", vbExclamation, "Cancelled"
        GoTo Clean
    ElseIf tbl.ListRows.Count = 0 Then
        MsgBox "Table has no rows", vbInformation, "Cancelled"
        GoTo Clean
    End If
    
    'Delete unwanted rows
    If Not KeepDatesOnly(tbl, rng.Column - tbl.Range.Column + 1) Then GoTo Clean
    
    Const searchText2 As String = "Voucher Id"
    Const searchText3 As String = "Vendor Id"
    Const searchText4 As String = "Merchandise"
    
    Call NumberFormat(searchText2, searchText3, tbl)
    Call UnicodeCleanup(tbl)
    Call UpdateMerchAmt(searchText4, tbl)
    
    'If code reached this far then there should be no reason to fail converting to a range
    tbl.Unlist
Clean:
    app.RestoreState
End Sub

Private Function GetZZAPPYMTSheet() As Worksheet
    Const expectedShtName As String = "ZZ_AP_PYMT"
    Dim ws As Worksheet
    Dim book As Workbook
    
    Set book = ActiveWorkbook
    If book Is Nothing Then
        'Can happen if this code is run within an AddIn (e.g. .xlam file)
        MsgBox "Please activate a Workbook", vbInformation, "Cancelled"
        Exit Function
    End If
    
    Set ws = GetWorksheetByName(expectedShtName, book)
    If ws Is Nothing Then
        If book.Worksheets.Count > 0 Then
            Set ws = book.Worksheets(1)
        Else
            MsgBox "No Worksheets found!" & vbNewLine & "Please select workbook containing <" _
                & expectedShtName & "> worksheet!", vbInformation, "Cancelled"
            Exit Function
        End If
    End If
    Set GetZZAPPYMTSheet = ws
End Function

Public Function GetWorksheetByName(ByVal wsName As String, ByVal book As Workbook) As Worksheet
    On Error Resume Next
    Set GetWorksheetByName = book.Worksheets(wsName)
    On Error GoTo 0
End Function

Private Function FindTextInRange(ByVal text As String, ByVal rng As Range) As Range
    On Error Resume Next
    Set FindTextInRange = rng.Find(What:=text, LookAt:=xlWhole)
    On Error GoTo 0
End Function

Public Function DeleteAboveRow(ByVal rowIndex As Long, ByVal ws As Worksheet) As Boolean
    If rowIndex <= 1 Then
        DeleteAboveRow = True
        Exit Function
    End If
    On Error Resume Next
    ws.Rows("1:" & rowIndex - 1).Delete xlShiftUp
    DeleteAboveRow = (Err.Number = 0)
    On Error GoTo 0
End Function

Private Function KeepDatesOnly(ByVal tbl As ListObject, ByVal columnIndex As Long) As Boolean
    'Sort table
    On Error Resume Next
    With tbl.Sort.SortFields
        .Clear
        .Add Key:=tbl.ListColumns(columnIndex).Range, SortOn:=xlSortOnValues _
            , Order:=xlAscending, DataOption:=xlSortNormal
    End With
    With tbl.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    If Err.Number <> 0 Then
        MsgBox "Cannot sort table!", vbExclamation, "Cancelled"
        Err.Clear
        Exit Function
    End If
    On Error GoTo 0
    
    Dim arr() As Variant: arr = tbl.ListColumns(columnIndex).DataBodyRange.Value2
    Dim i As Long
    Dim startRow As Long
    Dim endRow As Long
    
    'First, we find rows at the end
    startRow = 0
    endRow = 0
    For i = UBound(arr, 1) To LBound(arr, 1) Step -1
        If IsValidDate(arr(i, 1)) Then
            startRow = i + 1
            Exit For
        Else
            If endRow = 0 Then endRow = i
        End If
    Next i
    
    On Error GoTo FailDelete
    If startRow = 0 Then
        'Delete all rows
        tbl.DataBodyRange.Delete xlShiftUp
        KeepDatesOnly = True
        Exit Function
    ElseIf endRow > 0 Then
        tbl.DataBodyRange.Rows(startRow & ":" & endRow).Delete xlShiftUp
    End If
    On Error GoTo 0
    
    'Finally we delete rows at the beggining. By this stage we clearly have valid dates
    startRow = 0
    endRow = 0
    For i = LBound(arr, 1) To UBound(arr, 1)
        If IsValidDate(arr(i, 1)) Then
            endRow = i - 1
            Exit For
        Else
            If startRow = 0 Then startRow = i
        End If
    Next i
    
    On Error GoTo FailDelete
    If startRow > 0 Then
        tbl.DataBodyRange.Rows(startRow & ":" & endRow).Delete xlShiftUp
    End If
    On Error GoTo 0
    
    KeepDatesOnly = True
Exit Function
FailDelete:
    MsgBox "Cannot delete rows from table!", vbExclamation, "Cancelled"
    KeepDatesOnly = False
End Function

Private Function IsValidDate(ByVal v As Variant) As Boolean
    Const minDate As Date = #1/1/1990#
    Const maxDate As Date = #12/31/2099#
    
    On Error Resume Next
    v = CDate(v)
    On Error GoTo 0
    
    If VarType(v) = vbDate Then
        If v < minDate Or v > maxDate Then Exit Function
    Else
        Exit Function
    End If
    IsValidDate = True
End Function

Sub NumberFormat(ByVal venID As String, ByVal vouchID As String, ByVal tbl As ListObject)
    Dim foundCell As Range
    Dim foundCell2 As Range
    Dim rng As ListColumn
    Dim rng2 As ListColumn
    
    'Attempt to find string values in table header row
    On Error Resume Next
    Set foundCell = tbl.HeaderRowRange.Find(venID, _
        LookAt:=xlWhole)
    Set foundCell2 = tbl.HeaderRowRange.Find(vouchID, _
        LookAt:=xlWhole)
    Set rng = tbl.ListColumns(venID)
    Set rng2 = tbl.ListColumns(vouchID)
    On Error GoTo 0
    
    'Return table header number for specified value
    'Reformat Vendor Id column with 10 zeros & Voucher Id with 8 zeros
    If foundCell Is Nothing Then
        MsgBox "Value not found."
    Else
        rng.Range.NumberFormat = "0000000000"
    End If
    
    If foundCell2 Is Nothing Then
        MsgBox "Value not found."
    Else
        rng2.Range.NumberFormat = "00000000"
    End If
End Sub

Public Sub UnicodeCleanup(ByVal tbl As ListObject)
    If tbl Is Nothing Then Exit Sub
    If tbl.DataBodyRange Is Nothing Then Exit Sub
    With tbl.DataBodyRange
        .Replace What:=ChrW(8237), replacement:="", LookAt:=xlPart
        .Replace What:=ChrW(8236), replacement:="", LookAt:=xlPart
    End With
End Sub

Sub UpdateMerchAmt(ByVal merchAmt As String, ByVal tbl As ListObject)
    Dim mRng As Range
    Dim merchAmtNew As String
    merchAmtNew = "Merchandise Amount"
    
    'Search for Merchandise  Amount in table headers
    On Error Resume Next
    Set mRng = tbl.HeaderRowRange.Find(merchAmt, _
        LookAt:=xlPart)
    On Error GoTo 0
    
    If Not mRng Is Nothing Then
        mRng.Value = merchAmtNew
    Else
        MsgBox "Values not found. Remove space from " & merchAmt, vbExclamation, "Cancelled"
    End If
End Sub