Improve VBA Code to Run Faster

B

bmkelly

Board Regular
Joined
Mar 26, 2020
Messages
172
Office Version
  1. 365
Platform
  1. Windows
Hello,

I have a pretty lengthy code that takes about 4-5 minutes to run and was wondering if there is any improvements that could be made to it to help cut the run time down some?

VBA Code: 
Sub AscCSFormat()

Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False

'Select the correct worksheet and table then remove filters'
    Worksheets(15).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With

'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108

    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(15).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(15).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(15).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Dim oLo As ListObject, l As Long, note As String
    Set oLo = Worksheets(15).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
Dim LastColumn As Long

    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
        
ActiveSheet.ResetAllPageBreaks

Dim hdr As Range, f As Range, r As Range
Dim cell As String
  
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws As Worksheet

Set ws15 = Worksheets(15)
Set oLo = ws15.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws15.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With
        
'Select the correct worksheet and table then remove filters'
    Worksheets(16).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With
        
'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108
    
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(16).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(16).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(16).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Set oLo = Worksheets(16).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
        
ActiveSheet.ResetAllPageBreaks
 
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws16 As Worksheet

Set ws16 = Worksheets(16)
Set oLo = ws16.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws16.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With
        
'Select the correct worksheet and table then remove filters'
    Worksheets(17).Activate
    
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
        With Cells
            .EntireColumn.Hidden = False
            .EntireRow.Hidden = False
        End With
        
'Adjust column widths'
    Columns("E:E").ColumnWidth = 80
    Columns("F:F").ColumnWidth = 37
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").ColumnWidth = 60
    Columns("J:J").ColumnWidth = 60
    Columns("K:K").ColumnWidth = 108
    
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(17).ListObjects(1).Sort.SortFields.Add2 Key:=Range(Worksheets(17).ListObjects(1).Name & "[Description]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(17).ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Set oLo = Worksheets(17).ListObjects(1)
        With oLo
    For l = 1 To .ListRows.Count

note = "Retired - No Coverage"
        If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If

note = "All Parts & Labor"
        If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
            .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note
        End If
        
        Next l

        End With
        
'Change Header to Proration Date'
    Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
    If UCase(Cells(1, i)) = "CEID" Or UCase(Cells(1, i)) = "SERIAL" Or UCase(Cells(1, i)) = "RETIRED DATE" Or UCase(Cells(1, i)) = "PRORATION DATE" Then Columns(i).Hidden = True
        Next
    
ActiveSheet.ResetAllPageBreaks
  
    Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)
        If Not hdr Is Nothing Then
    Set r = Columns(hdr.Column)
    Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
        If Not f Is Nothing Then
            cell = f.Address
        Do
            f.Offset(1).PageBreak = xlPageBreakManual
        Set f = r.FindNext(f)
        
      Loop While Not f Is Nothing And f.Address <> cell
      
    End If
    
  End If
     
Dim ws17 As Worksheet

Set ws17 = Worksheets(17)
Set oLo = ws17.ListObjects(1)

With oLo
    For i = 1 To .ListRows.Count
        If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
            If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                ws17.Rows(oLo.HeaderRowRange.Row + i).Hidden = True
            End If
        End If
    Next i
End With

    Sheets("Cover Page").Select
    Range("O1").Select

Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.EnableEvents = True
        
End Sub
 
Sort by date Sort by votes
Ok Give this a try to see if it works accurately:

VBA Code: 
Sub AscCSFormat()
'
    Dim startTime                       As Single
'
    startTime = Timer                                                                           ' Start the stopwatch
''
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo                             As ListObject
    Dim l                               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim AnnualServicePriceColumNumber   As Long, TransactionDateColumnNumber            As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber            As Long
    Dim f                               As Range, hdr       As Range, r                 As Range
    Dim RowsToHideRange                 As Range
    Dim cell                            As String
    Dim TableArray                      As Variant
'
'---------------------------------------------------------------------------------------------------------------------
'
    For WorkSheetNumber = 15 To 17
'       Select the correct worksheet and table then remove filters'
        Worksheets(WorkSheetNumber).Activate
'
        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)
'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False
'
'       Adjust column widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108
'
        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'
        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    ' Get column # for "Transaction Type" column
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   ' Get column # for "TriMedx Coverage" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If
'
            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next
'
        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table
'
        On Error Resume Next
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ActiveSheet.ResetAllPageBreaks
'
        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
'
            If Not f Is Nothing Then
                cell = f.Address
'
                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If
'
        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column    ' Get column # for "Annual Service Price" column
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column   ' Get column # for "Transaction Date" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
'
        RowsToHideRange.EntireRow.Hidden = True                                                     ' Hide all rows to be hidden in one swoop
    Next
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' about 7 seconds for 1 sheet
End Sub
 
Upvote 0

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
johnnyL said:
Ok Give this a try to see if it works accurately:

VBA Code: 
Sub AscCSFormat()
'
    Dim startTime                       As Single
'
    startTime = Timer                                                                           ' Start the stopwatch
''
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo                             As ListObject
    Dim l                               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim AnnualServicePriceColumNumber   As Long, TransactionDateColumnNumber            As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber            As Long
    Dim f                               As Range, hdr       As Range, r                 As Range
    Dim RowsToHideRange                 As Range
    Dim cell                            As String
    Dim TableArray                      As Variant
'
'---------------------------------------------------------------------------------------------------------------------
'
    For WorkSheetNumber = 15 To 17
'       Select the correct worksheet and table then remove filters'
        Worksheets(WorkSheetNumber).Activate
'
        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)
'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False
'
'       Adjust column widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108
'
        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'
        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    ' Get column # for "Transaction Type" column
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   ' Get column # for "TriMedx Coverage" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If
'
            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next
'
        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table
'
        On Error Resume Next
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ActiveSheet.ResetAllPageBreaks
'
        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
'
            If Not f Is Nothing Then
                cell = f.Address
'
                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If
'
        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column    ' Get column # for "Annual Service Price" column
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column   ' Get column # for "Transaction Date" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
'
        RowsToHideRange.EntireRow.Hidden = True                                                     ' Hide all rows to be hidden in one swoop
    Next
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' about 7 seconds for 1 sheet
End Sub
Click to expand...
This ran incredibly fast (12.45 seconds)! However my transaction sheets have all the data hidden so it is hard for me to find out if it truly does everything we are telling the code to do (I have to unhide all to see the data - therefor unsure if it actually hides $0 transactions and the specific columns we state in the code). I also updated the UCase code to add a Trim since I was having issues previously where "Proration date " on some templates had a space and UCase doesn't catch that so in a different post and individual helped me out with a Trim code that I applied.

VBA Code: 
Sub AscCSFormatTest()

'Start Stopwatch'
Dim startTime As Single
    startTime = Timer

    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim oLo As ListObject
    Dim l As Long, LastColumn As Long, WorkSheetNumber As Long
    Dim AnnualServicePriceColumNumber As Long, TransactionDateColumnNumber As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber As Long
    Dim f As Range, hdr As Range, r As Range
    Dim RowsToHideRange As Range
    Dim cell As String
    Dim TableArray As Variant

    For WorkSheetNumber = 15 To 17
    
'Select the Correct Worksheet and Table then Remove Filters'
        Worksheets(WorkSheetNumber).Activate

        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)

'Remove Filters'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0

'Unhide Columns/Rows'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False

'Adjust Column Widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108

        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    'Get Column # For "Transaction Type" Column'
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   'Get Column # For "TriMedx Coverage" Column'

        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   'Save Table Into TableArray Without Header'
''TableArray = ActiveSheet.ListObjects(1).Range'                                                                 'Save Table Into TableArray With Header'

        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If

            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next

        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   'Save TableArray Back Into The Table'

        On Error Resume Next
        
'Hide Columns'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

        For i = 1 To LastColumn
            If Trim(UCase(Cells(1, i))) = "CEID" Or Trim(UCase(Cells(1, i))) = "SERIAL" Or Trim(UCase(Cells(1, i))) = "RETIRED DATE" _
                Or Trim(UCase(Cells(1, i))) = "PRORATION DATE" Then Columns(i).Hidden = True
                    Columns(i).Hidden = True
        Next

'Page Breaks'
        ActiveSheet.ResetAllPageBreaks

        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)

            If Not f Is Nothing Then
                cell = f.Address

                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If

        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column     'Get Column # For "Annual Service Price" Column'
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column           'Get Column # For "Transaction Date" Column'

TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                           'Save Table Into TableArray Without Header'
''TableArray = ActiveSheet.ListObjects(1).Range'                                                                 'Save Table Into TableArray With Header'

'Hide $0 Transactions'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
        
        RowsToHideRange.EntireRow.Hidden = True                                                            'Hide All Rows to be Hidden in One Swoop'
    Next

    Application.Goto Sheets("Cover Page").Range("O1")

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                             'About 7 Seconds for 1 Sheet

End Sub
 
Upvote 0
I am confused to your response.

bmkelly said:
This ran incredibly fast (12.45 seconds)! However my transaction sheets have all the data hidden so it is hard for me to find out if it truly does everything we are telling the code to do (I have to unhide all to see the data - therefor unsure if it actually hides $0 transactions and the specific columns we state in the code).
Click to expand...

Why is all of the data hidden? The code I submitted doesn't do that.
 
Upvote 0
johnnyL said:
I am confused to your response.



Why is all of the data hidden? The code I submitted doesn't do that.
Click to expand...
I am not sure why the data is hidden either. The only thing I changed inside of your code is from:
VBA Code: 
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next

To this code (I needed to add Trim as UCase does not pick up on any spaces in the header)
VBA Code: 
'Hide Columns'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

        For i = 1 To LastColumn
            If Trim(UCase(Cells(1, i))) = "CEID" Or Trim(UCase(Cells(1, i))) = "SERIAL" Or Trim(UCase(Cells(1, i))) = "RETIRED DATE" _
                Or Trim(UCase(Cells(1, i))) = "PRORATION DATE" Then Columns(i).Hidden = True
                    Columns(i).Hidden = True
        Next

Outside of that, this is the code I ran (which is copied from your code above):
VBA Code: 
Sub AscCSFormatTest()

'Start Stopwatch'
Dim startTime As Single
    startTime = Timer

    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim oLo As ListObject
    Dim l As Long, LastColumn As Long, WorkSheetNumber As Long
    Dim AnnualServicePriceColumNumber As Long, TransactionDateColumnNumber As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber As Long
    Dim f As Range, hdr As Range, r As Range
    Dim RowsToHideRange As Range
    Dim cell As String
    Dim TableArray As Variant

    For WorkSheetNumber = 15 To 17
  
'Select the Correct Worksheet and Table then Remove Filters'
        Worksheets(WorkSheetNumber).Activate

        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)

'Remove Filters'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0

'Unhide Columns/Rows'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False

'Adjust Column Widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108

        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    'Get Column # For "Transaction Type" Column'
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   'Get Column # For "TriMedx Coverage" Column'

        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   'Save Table Into TableArray Without Header'
''TableArray = ActiveSheet.ListObjects(1).Range'                                                                 'Save Table Into TableArray With Header'

        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If

            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next

        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   'Save TableArray Back Into The Table'

        On Error Resume Next
      
'Hide Columns'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

        For i = 1 To LastColumn
            If Trim(UCase(Cells(1, i))) = "CEID" Or Trim(UCase(Cells(1, i))) = "SERIAL" Or Trim(UCase(Cells(1, i))) = "RETIRED DATE" _
                Or Trim(UCase(Cells(1, i))) = "PRORATION DATE" Then Columns(i).Hidden = True
                    Columns(i).Hidden = True
        Next

'Page Breaks'
        ActiveSheet.ResetAllPageBreaks

        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)

            If Not f Is Nothing Then
                cell = f.Address

                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If

        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column     'Get Column # For "Annual Service Price" Column'
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column           'Get Column # For "Transaction Date" Column'

TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                           'Save Table Into TableArray Without Header'
''TableArray = ActiveSheet.ListObjects(1).Range'                                                                 'Save Table Into TableArray With Header'

'Hide $0 Transactions'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
      
        RowsToHideRange.EntireRow.Hidden = True                                                            'Hide All Rows to be Hidden in One Swoop'
    Next

    Application.Goto Sheets("Cover Page").Range("O1")

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                             'About 7 Seconds for 1 Sheet

End Sub
And this is what my one of my Transaction Sheets show (I am scrolled all the way up and all the way left):
1645410020078.png


Edit- I grabbed your code (verbatim) without making any changes to it (Not adding "Trim" to the Proration Date Section) and I actually get Run-time error '1004': Method 'Union of object '_Global' failed
1645409937416.png
 
Last edited:
Upvote 0
wow from 4-5mins down to 3! to some that's a mere 2mins deduction but to coders its much more than that! I just hope when I finish my code someone could also help me :) as of now my tables stand at 853 records and process 49seconds! but I'm thinking to process 48secs for a mere 853 records!
I believe my code is somewhat a turtle in comparison
 
Upvote 0
bmkelly said:
And this is what my one of my Transaction Sheets show (I am scrolled all the way up and all the way left):
View attachment 58337
Click to expand...

No attachment seen there.


Did you test all of the sheets that are ran through in the code? I suppose if some variables weren't reset you could possibly encounter a problem.

Run the following code to see if same thing happens:

VBA Code: 
Sub AscCSFormat()
'
    Dim startTime                       As Single
'
    startTime = Timer                                                                           ' Start the stopwatch
''
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo                             As ListObject
    Dim l                               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim AnnualServicePriceColumNumber   As Long, TransactionDateColumnNumber            As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber            As Long
    Dim f                               As Range, hdr       As Range, r                 As Range
    Dim RowsToHideRange                 As Range
    Dim cell                            As String
    Dim TableArray                      As Variant
'
'---------------------------------------------------------------------------------------------------------------------
'
''''''    For WorkSheetNumber = 15 To 17
'       Select the correct worksheet and table then remove filters'
''''''        Worksheets(WorkSheetNumber).Activate
        Worksheets("FY22 Transactions").Activate
'
''''''        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)
        Set oLo = Worksheets("FY22 Transactions").ListObjects(1)
'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False
'
'       Adjust column widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108
'
''''''        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
        With ActiveWorkbook.Worksheets("FY22 Transactions").ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'
        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    ' Get column # for "Transaction Type" column
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   ' Get column # for "TriMedx Coverage" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If
'
            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next
'
        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table
'
        On Error Resume Next
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ActiveSheet.ResetAllPageBreaks
'
        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
'
            If Not f Is Nothing Then
                cell = f.Address
'
                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If
'
        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column    ' Get column # for "Annual Service Price" column
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column   ' Get column # for "Transaction Date" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
'
        RowsToHideRange.EntireRow.Hidden = True                                                     ' Hide all rows to be hidden in one swoop
''''''    Next
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' about 7 seconds for 1 sheet
End Sub

That code will run just on the 'FY22 Transactions' sheet. Don't change it, just run it.
 
Upvote 0
I
johnnyL said:
No attachment seen there.


Did you test all of the sheets that are ran through in the code? I suppose if some variables weren't reset you could possibly encounter a problem.

Run the following code to see if same thing happens:

VBA Code: 
Sub AscCSFormat()
'
    Dim startTime                       As Single
'
    startTime = Timer                                                                           ' Start the stopwatch
''
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo                             As ListObject
    Dim l                               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim AnnualServicePriceColumNumber   As Long, TransactionDateColumnNumber            As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber            As Long
    Dim f                               As Range, hdr       As Range, r                 As Range
    Dim RowsToHideRange                 As Range
    Dim cell                            As String
    Dim TableArray                      As Variant
'
'---------------------------------------------------------------------------------------------------------------------
'
''''''    For WorkSheetNumber = 15 To 17
'       Select the correct worksheet and table then remove filters'
''''''        Worksheets(WorkSheetNumber).Activate
        Worksheets("FY22 Transactions").Activate
'
''''''        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)
        Set oLo = Worksheets("FY22 Transactions").ListObjects(1)
'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False
'
'       Adjust column widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108
'
''''''        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
        With ActiveWorkbook.Worksheets("FY22 Transactions").ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'
        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    ' Get column # for "Transaction Type" column
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   ' Get column # for "TriMedx Coverage" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If
'
            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next
'
        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table
'
        On Error Resume Next
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ActiveSheet.ResetAllPageBreaks
'
        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
'
            If Not f Is Nothing Then
                cell = f.Address
'
                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If
'
        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column    ' Get column # for "Annual Service Price" column
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column   ' Get column # for "Transaction Date" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
'
        RowsToHideRange.EntireRow.Hidden = True                                                     ' Hide all rows to be hidden in one swoop
''''''    Next
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' about 7 seconds for 1 sheet
End Sub

That code will run just on the 'FY22 Transactions' sheet. Don't change it, just run it.
Click to expand...
Sorry not sure why the attachment didn't go thru. Here is what it originally would look like when I ran your previous code (It seemed to hide columns A:AK)
Here are the results to running the overall code: Box
1645410602162.png


As for your most recent code to just run on FY22 Transaction Sheet, it seemed to run perfectly fine (outside of a few $0 transactions still showing) but no errors and data isnt hidden.
Here are the results for running just the FY22 Transaction Sheet code: Box
 
Upvote 0
airforceone said:
wow from 4-5mins down to 3! to some that's a mere 2mins deduction but to coders its much more than that! I just hope when I finish my code someone could also help me :) as of now my tables stand at 853 records and process 49seconds! but I'm thinking to process 48secs for a mere 853 records!
I believe my code is somewhat a turtle in comparison
Click to expand...
It originally was 8 minutes until I added in the following
VBA Code: 
    Application.Calculation = xlManual
    Application.EnableEvents = False

    Application.Calculation = xlAutomatic
    Application.EnableEvents = True

Doing that cut it down to 4 minutes, now currently Johnny and noSparx have been helping tremendously and cutting even down to just seconds with a few hiccups we have to overcome! This is with an estimated 3k records across 3 sheets.
 
Upvote 0
Update - When I run just your code with not edits/updates I get Run-time error '1004': Method 'Union of object '_Global' failed (See Post #24) as it would error on:

VBA Code: 
Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))

So I went ahead and replaced that code with what we originally had which was:
VBA Code: 
        With oLo
            For i = 1 To .ListRows.Count
                If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
                    If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                        Worksheets(WorkSheetNumber).Rows(oLo.HeaderRowRange.Row + i).Hidden = True
                    End If
                End If
            Next
        End With
    Next

And also had to remove as it gave me an error as well:
VBA Code: 
RowsToHideRange.EntireRow.Hidden = True

Doing that successfully ran the entire code (although it took significantly longer 109.14 seconds compared to the 12.45 seconds in post #22) however I did end up with the correct results to be shown with the following code:
VBA Code: 
Sub AscCSFormatTest()

'Start Stopwatch'
Dim startTime As Single
    startTime = Timer

    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim oLo As ListObject
    Dim l As Long, LastColumn As Long, WorkSheetNumber As Long
    Dim AnnualServicePriceColumNumber As Long, TransactionDateColumnNumber As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber As Long
    Dim f As Range, hdr As Range, r As Range
    Dim RowsToHideRange As Range
    Dim cell As String
    Dim TableArray As Variant

    For WorkSheetNumber = 15 To 17
    
'Select the Correct Worksheet and Table then Remove Filters'
        Worksheets(WorkSheetNumber).Activate

        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)

'Remove Filters'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0

'Unhide Columns/Rows'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False

'Adjust Column Widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108

        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    'Get Column # For "Transaction Type" Column'
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   'Get Column # For "TriMedx Coverage" Column'

        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   'Save Table Into TableArray Without Header'
        ''TableArray = ActiveSheet.ListObjects(1).Range'                                                        'Save Table Into TableArray With Header'

        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If

            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next

        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   'Save TableArray Back Into The Table'

        On Error Resume Next
        
'Update Proration Date Header'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0

'Hide Columns'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next

'Page Breaks'
        ActiveSheet.ResetAllPageBreaks

        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)

            If Not f Is Nothing Then
                cell = f.Address

                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If

        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column     'Get Column # For "Annual Service Price" Column'
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column           'Get Column # For "Transaction Date" Column'

        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                           'Save Table Into TableArray Without Header'
        ''TableArray = ActiveSheet.ListObjects(1).Range'                                                                'Save Table Into TableArray With Header'

'Hide $0 Transactions'
        With oLo
            For i = 1 To .ListRows.Count
                If .ListColumns("Annual Service Price").DataBodyRange.Cells(i, 1).Value = 0 Then
                    If InStr(.ListColumns("Transaction Date").DataBodyRange.Cells(i, 1).Value, "Total") = 0 Then
                        Worksheets(WorkSheetNumber).Rows(oLo.HeaderRowRange.Row + i).Hidden = True
                    End If
                End If
            Next
        End With
    Next
       
    Application.Goto Sheets("Cover Page").Range("O1")

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                             'About 7 Seconds for 1 Sheet

End Sub

Hope this helps in some way as I am not too entirely sure why it didn't like the "RowstoHideRange" portion, but I was just curious if i reverted back the code it errored out on if I would get a successful run thru (which I did) and it is still faster than the original original code I had prior to you making some tweaks!
 
Upvote 0
Try the following:

VBA Code: 
Sub AscCSFormat()
'
    Dim startTime                       As Single
'
    startTime = Timer                                                                           ' Start the stopwatch
''
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo                             As ListObject
    Dim l                               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim AnnualServicePriceColumNumber   As Long, TransactionDateColumnNumber            As Long
    Dim TransactionTypeColumNumber      As Long, TriMedxCoverageColumnNumber            As Long
    Dim f                               As Range, hdr       As Range, r                 As Range
    Dim RowsToHideRange                 As Range
    Dim cell                            As String
    Dim TableArray                      As Variant
'
'---------------------------------------------------------------------------------------------------------------------
'
    For WorkSheetNumber = 15 To 17
'       Select the correct worksheet and table then remove filters'
        Worksheets(WorkSheetNumber).Activate
'
        Set oLo = Worksheets(WorkSheetNumber).ListObjects(1)
'
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
'
        Columns.EntireColumn.Hidden = False
        Rows.EntireRow.Hidden = False
'
'       Adjust column widths'
        Columns("E:E").ColumnWidth = 80
        Columns("F:F").ColumnWidth = 37
        Range("G:H").EntireColumn.AutoFit
        Columns("I:J").ColumnWidth = 60
        Columns("K:K").ColumnWidth = 108
'
        With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(oLo.Name & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Range(oLo.Name & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
'
        TransactionTypeColumNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Type").Range.Column    ' Get column # for "Transaction Type" column
        TriMedxCoverageColumnNumber = ActiveSheet.ListObjects(1).ListColumns("TriMedx Coverage").Range.Column   ' Get column # for "TriMedx Coverage" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For l = 1 To oLo.ListRows.Count
            If TableArray(l, TransactionTypeColumNumber) = "Retirement" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "Retired - No Coverage"
            End If
'
            If TableArray(l, TriMedxCoverageColumnNumber) = "Missing Coverage" Then
                TableArray(l, TriMedxCoverageColumnNumber) = "All Parts & Labor"
            End If
        Next
'
        ActiveSheet.ListObjects(1).DataBodyRange = TableArray                                                   ' Save TableArray back into the table
'
        On Error Resume Next
'       Change Header to Proration Date'
        Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        On Error GoTo 0
'
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case UCase(Cells(1, i))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ActiveSheet.ResetAllPageBreaks
'
        Set hdr = Rows(1).Find("Transaction Date", , xlValues, xlWhole, , , False)

        If Not hdr Is Nothing Then
            Set r = Columns(hdr.Column)
            Set f = r.Find("*Total*", , xlValues, xlPart, , , False)
'
            If Not f Is Nothing Then
                cell = f.Address
'
                Do
                    f.Offset(1).PageBreak = xlPageBreakManual
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
            End If
        End If
'
        AnnualServicePriceColumNumber = ActiveSheet.ListObjects(1).ListColumns("Annual Service Price").Range.Column    ' Get column # for "Annual Service Price" column
        TransactionDateColumnNumber = ActiveSheet.ListObjects(1).ListColumns("Transaction Date").Range.Column   ' Get column # for "Transaction Date" column
'
''        TableArray = ActiveSheet.ListObjects(1).DataBodyRange                                                   ' Save table into TableArray without header
        TableArray = ActiveSheet.ListObjects(1).Range                                                           ' Save table into TableArray with header
'
        For i = 1 To oLo.ListRows.Count
            If TableArray(i, AnnualServicePriceColumNumber) = 0 Then
                If InStr(TableArray(i, TransactionDateColumnNumber), "Total") = 0 Then
                    If RowsToHideRange Is Nothing Then
                        Set RowsToHideRange = Range(Cells(i, 1), Cells(i, 26))
                    Else
                        Set RowsToHideRange = Union(RowsToHideRange, Range(Cells(i, 1), Cells(i, 26)))
                    End If
                End If
            End If
        Next
'
        RowsToHideRange.EntireRow.Hidden = True                                                     ' Hide all rows to be hidden in one swoop
'
        Set RowsToHideRange = Nothing
    Next
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' about 7 seconds for 1 sheet
End Sub

That resets the only variable that I can think would cause an issue when going to the next sheet.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
A little VBA/Macro code adjustment
Replies
3
Views
294
rollis13
rollis13
A
  • Solved
VBA - button to sort by date in ascending and descending order
Replies
6
Views
2K
Peter_SSs
Peter_SSs
N
  • Question Question
ActiveX Option Button to sort Data in another sheet and update conbobox
2 3
Replies
22
Views
344
NUC_N_FUTS2
N
I
  • Question Question
Apply delay before running code
Replies
8
Views
262
ipbr21054
I
I
  • Solved
Simplify my working code please
Replies
7
Views
186
ipbr21054
I

Forum statistics

Threads
1,224,827
Messages
6,181,200
Members
453,022
Latest member
RobertV1609

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top