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
bmkelly said:
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
Click to expand...

Sounds like you are down under 2 minutes now. Now if we can get that hidden row code part fixed, you will be under 30 seconds hopefully. :)
 
Upvote 0

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
johnnyL said:
Sounds like you are down under 2 minutes now. Now if we can get that hidden row code part fixed, you will be under 30 seconds hopefully. :)
Click to expand...
Yes! I will check out your code from post #30 in the morning and see what results it gives me and give feedback on here!

Overall for this specific file I have been testing with, this has gone from roughly 8 minutes down to just under 2 minutes so I will take that as a huge win!

But yes, would love to cut down more if possible (especially on the larger files that contain 5k plus records to sort thru)!
 
Upvote 0
I see I'm late returning to the party

The issue I was having was the .Find function not finding Annual Service Price in row 1.
An ascii check of the cell showed everything as expected but no go.
When I changed to using .ListColumns("Annual Service Price").Range.Column (thanks johnnyL) it worked.
Same cell, same content, accepted as table header but not by .Find as what's in the cell ??? don't know how that works.

It never dawned on me that you wouldn't want to keep the formulas.
Any how, here's my contribution.
It is set up to do all *Transaction* sheets in the workbook, as per your other request.
Code is slightly modified for my Excel 2010 and will take a little longer than the array approach to run on the test file you supplied.
VBA Code: 
Sub AscCSFormat_vNS()

    Dim ws As Worksheet, oLo As ListObject
    Dim transCol As Long, trimedCol As Long
    Dim aspCol As Long, transdteCol As Long
    Dim visRng As Range, i As Long
    Dim note1 As String, note2 As String
    
    Dim LastColumn As Long
    Dim f As Range, hdr As Range, r As Range
    Dim cell As String
    
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
For Each ws In ThisWorkbook.Worksheets
    If ws.Name Like "*Transactions*" Then
        With ws
            ' make active
            .Activate
            ' show all data
            On Error Resume Next
            ws.ShowAllData
            On Error GoTo 0
            .Columns.Hidden = False
            .Rows.Hidden = False
            
            ' correct Proration Date header -- altered slightly for Excel 2010
            .Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
            
            ' 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
            
            ' set the table
            Set oLo = ws.ListObjects(1)
        End With
        
        ' sort the table -- altered slightly for Excel 2010
        With oLo.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(oLo & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        
        ' change some verbage
        note1 = "Retired - No Coverage"
        note2 = "All Parts & Labor"
        
        ' columns to use for filtering
        transCol = oLo.ListColumns("Transaction Type").Range.Column
        trimedCol = oLo.ListColumns("TriMedx Coverage").Range.Column
        aspCol = oLo.ListColumns("Annual Service Price").Range.Column
        transdteCol = oLo.ListColumns("Transaction Date").Range.Column

        With oLo.Range
            .AutoFilter Field:=transCol, Criteria1:="Retirement"
                Set visRng = oLo.ListColumns(trimedCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                If Not visRng Is Nothing Then
                    visRng.Value = note1
                    Set visRng = Nothing
                End If
                .AutoFilter ' removes existing filter
            .AutoFilter Field:=trimedCol, Criteria1:="Missing Coverage"
                On Error Resume Next    ' running a second time, this errors
                Set visRng = oLo.ListColumns(trimedCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not visRng Is Nothing Then
                    visRng.Value = note2
                    Set visRng = Nothing
                End If
                .AutoFilter ' removes existing filter
            ' for hiding O value Annual Service Price
            .AutoFilter Field:=aspCol, Criteria1:="$-"
            .AutoFilter Field:=transdteCol, Criteria1:="<>" & "*Total*"
                On Error Resume Next
                Set visRng = oLo.ListColumns(aspCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                .AutoFilter ' remove filter
                If Not visRng Is Nothing Then
                    visRng.EntireRow.Hidden = True
                    Set visRng = Nothing
                End If
        End With

'
        ' hide some columns
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case Trim(UCase(Cells(1, i)))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ' remove any manually set page breaks
        ActiveSheet.ResetAllPageBreaks
'
        ' set manual page breaks
        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
'
    
    End If   ' end of dealing with this worksheet
    
Next ws      ' loop to next worksheet
'
    'Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic

End Sub
 
Upvote 0
Solution
NoSparks said:
I see I'm late returning to the party

The issue I was having was the .Find function not finding Annual Service Price in row 1.
An ascii check of the cell showed everything as expected but no go.
When I changed to using .ListColumns("Annual Service Price").Range.Column (thanks johnnyL) it worked.
Same cell, same content, accepted as table header but not by .Find as what's in the cell ??? don't know how that works.

It never dawned on me that you wouldn't want to keep the formulas.
Any how, here's my contribution.
It is set up to do all *Transaction* sheets in the workbook, as per your other request.
Code is slightly modified for my Excel 2010 and will take a little longer than the array approach to run on the test file you supplied.
VBA Code: 
Sub AscCSFormat_vNS()

    Dim ws As Worksheet, oLo As ListObject
    Dim transCol As Long, trimedCol As Long
    Dim aspCol As Long, transdteCol As Long
    Dim visRng As Range, i As Long
    Dim note1 As String, note2 As String
 
    Dim LastColumn As Long
    Dim f As Range, hdr As Range, r As Range
    Dim cell As String
 
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
For Each ws In ThisWorkbook.Worksheets
    If ws.Name Like "*Transactions*" Then
        With ws
            ' make active
            .Activate
            ' show all data
            On Error Resume Next
            ws.ShowAllData
            On Error GoTo 0
            .Columns.Hidden = False
            .Rows.Hidden = False
         
            ' correct Proration Date header -- altered slightly for Excel 2010
            .Rows("1:1").Replace What:="*Proration Date*", Replacement:="Proration Date", LookAt:=xlPart, SearchOrder:=xlByRows, _
                MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2
         
            ' 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
         
            ' set the table
            Set oLo = ws.ListObjects(1)
        End With
     
        ' sort the table -- altered slightly for Excel 2010
        With oLo.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(oLo & "[QuarterSerial]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Transaction Code]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Absolute Value]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=Range(oLo & "[Description]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
     
     
        ' change some verbage
        note1 = "Retired - No Coverage"
        note2 = "All Parts & Labor"
     
        ' columns to use for filtering
        transCol = oLo.ListColumns("Transaction Type").Range.Column
        trimedCol = oLo.ListColumns("TriMedx Coverage").Range.Column
        aspCol = oLo.ListColumns("Annual Service Price").Range.Column
        transdteCol = oLo.ListColumns("Transaction Date").Range.Column

        With oLo.Range
            .AutoFilter Field:=transCol, Criteria1:="Retirement"
                Set visRng = oLo.ListColumns(trimedCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                If Not visRng Is Nothing Then
                    visRng.Value = note1
                    Set visRng = Nothing
                End If
                .AutoFilter ' removes existing filter
            .AutoFilter Field:=trimedCol, Criteria1:="Missing Coverage"
                On Error Resume Next    ' running a second time, this errors
                Set visRng = oLo.ListColumns(trimedCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not visRng Is Nothing Then
                    visRng.Value = note2
                    Set visRng = Nothing
                End If
                .AutoFilter ' removes existing filter
            ' for hiding O value Annual Service Price
            .AutoFilter Field:=aspCol, Criteria1:="$-"
            .AutoFilter Field:=transdteCol, Criteria1:="<>" & "*Total*"
                On Error Resume Next
                Set visRng = oLo.ListColumns(aspCol).DataBodyRange.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                .AutoFilter ' remove filter
                If Not visRng Is Nothing Then
                    visRng.EntireRow.Hidden = True
                    Set visRng = Nothing
                End If
        End With

'
        ' hide some columns
        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
'
        For i = 1 To LastColumn
            Select Case Trim(UCase(Cells(1, i)))
                Case "CEID", "SERIAL", "RETIRED DATE", "PRORATION DATE"
                    Columns(i).Hidden = True
            End Select
        Next
'
        ' remove any manually set page breaks
        ActiveSheet.ResetAllPageBreaks
'
        ' set manual page breaks
        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
'
 
    End If   ' end of dealing with this worksheet
 
Next ws      ' loop to next worksheet
'
    'Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic

End Sub
Click to expand...
I am glad you said something about the formulas.....and you all will probably hate me but we do need the formulas to stay in the workbook. It is a vital and crucial part to our future quarters work when entering new data.

I ran Johnnys code in Post #30 and it did run without hiding the entire table in 15.38 seconds - however like NoSparks stated, it does remove the formulas (and I apologize for not catching that sooner/making it more clear to keep those formulas in the table). I also noticed when running this code the last transaction (before the each of the totals) it keeps a $0 transaction.

Here are a few screenshots of the $0 still showing:
1645448268310.png
1645448281929.png


As for NoSparks Macro on Post #33, it seems to run (less than a second) with no errors but doesn't seem to do anything?
 
Upvote 0
bmkelly said:
As for NoSparks Macro on Post #33, it seems to run (less than a second) with no errors but doesn't seem to do anything?
Click to expand...
less than a seccond.... it didn't run.
takes 12.5 seconds on my computer on the one sheet you supplied.
try running it using the F8 key to varify that it does run or at least to see what's happening for it to skip everything.
 
Upvote 0
NoSparks said:
less than a seccond.... it didn't run.
takes 12.5 seconds on my computer on the one sheet you supplied.
try running it using the F8 key to varify that it does run or at least to see what's happening for it to skip everything.
Click to expand...
My apologies, I had ran it on my original file and not the test. I did run it on the Test file I provided you and it had the same outcome. I stepped into the code and it looks like it goes straight from
VBA Code: 
If ws.Name Like "*Transactions*" Then
to
VBA Code: 
End If   ' end of dealing with this worksheet
and then Ends the Sub
 
Upvote 0
when on that If line,
you position the cursor on ws.Name,
is what's show a match for *Transactions* ?
 
Upvote 0
Here's a copy of your file with 3 sheets added for test purposes,
one visible and one hidden ahead of your sheet and one after your sheet.
My macro has been added and the file saved as .xlsm
app.box.com

Test - Copy.xlsm | Powered by Box

app.box.com app.box.com
You're telling me that the macro, when run, doesn't do anything, is that correct ?
 
Upvote 0
NoSparks said:
Here's a copy of your file with 3 sheets added for test purposes,
one visible and one hidden ahead of your sheet and one after your sheet.
My macro has been added and the file saved as .xlsm
app.box.com

Test - Copy.xlsm | Powered by Box

app.box.com app.box.com
You're telling me that the macro, when run, doesn't do anything, is that correct ?
Click to expand...
I just downloaded your Test - Copy and ran your NoSparx macro and it seemed to run fine (although I am seeing quite a few blank rows with coverage - not sure if thats part of the original file or not though) but outside of it all it seems to run no issues. I will take this code and add to one of the actual files
 
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,828
Messages
6,181,201
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