Return to Question

Tweeted twitter.com/StackCodeReview/status/1362507181938118657

occurred Feb 18, 2021 at 21:00

Added the ExcelAppState class to complete the question

Source Link

edit approved Feb 3, 2021 at 0:04

1.8k
6
29

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

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

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

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

Source Link

asked Jan 28, 2021 at 14:43

Bob the Builder

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

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