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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
The following is my first sweep of the code. See if it gives the same results:

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note     As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    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.oLo.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
'
        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
        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
'
        Set oLo = Worksheets(WorkSheetNumber).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
                        Worksheets(WorkSheetNumber).Rows(oLo.HeaderRowRange.Row + i).Hidden = True
                    End If
                End If
            Next
        End With
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
End Sub
 
Upvote 0
johnnyL said:
The following is my first sweep of the code. See if it gives the same results:

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note     As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    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.oLo.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
'
        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
        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
'
        Set oLo = Worksheets(WorkSheetNumber).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
                        Worksheets(WorkSheetNumber).Rows(oLo.HeaderRowRange.Row + i).Hidden = True
                    End If
                End If
            Next
        End With
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
End Sub
Click to expand...
Thanks for looking into this! I took the code and I get an error so when I debug the error lays on
VBA Code: 
With ActiveWorkbook.oLo.Sort

Outside of that error, I really like how clean your code is compared to mine!
 
Upvote 0
johnnyL said:
The following is my first sweep of the code. See if it gives the same results:

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note     As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    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.oLo.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
'
        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
        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
'
        Set oLo = Worksheets(WorkSheetNumber).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
                        Worksheets(WorkSheetNumber).Rows(oLo.HeaderRowRange.Row + i).Hidden = True
                    End If
                End If
            Next
        End With
'
'---------------------------------------------------------------------------------------------------------------------
'
    Application.Goto Sheets("Cover Page").Range("O1")
'
      Application.EnableEvents = True
    Application.ScreenUpdating = True
       Application.Calculation = xlAutomatic
End Sub
Click to expand...
bmkelly said:
Thanks for looking into this! I took the code and I get an error so when I debug the error lays on
VBA Code: 
With ActiveWorkbook.oLo.Sort

Outside of that error, I really like how clean your code is compared to mine!
Click to expand...
Edit - I ran the code with out the Custom Sort Code

VBA Code: 
With ActiveWorkbook.oLo.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

And it did run successfully and ran faster (approximately 3 minutes)
 
Upvote 0
If you get an error with the following code;

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note     As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    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.oLo.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
'
        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
        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
'
        Set oLo = Worksheets(WorkSheetNumber).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
                        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
End Sub

Please post the line and exact error you get.
 
Upvote 0
johnnyL said:
If you get an error with the following code;

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note     As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    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.oLo.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
'
        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
        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
'
        Set oLo = Worksheets(WorkSheetNumber).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
                        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
End Sub

Please post the line and exact error you get.
Click to expand...
Sorry I didn't include the error message in my response above:
1645188638536.png

Where it errored out on (when I click Debug)
1645188699108.png
 
Upvote 0
Try replacing that line that errors with:

VBA Code: 
With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
 
Upvote 0
johnnyL said:
Try replacing that line that errors with:

VBA Code: 
With ActiveWorkbook.Worksheets(WorkSheetNumber).ListObjects(1).Sort
Click to expand...
Thank you!

Taking your version has brought the process down to 3 minutes!
 
Upvote 0
Few more changes:

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note1    As String, note2            As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    note1 = "Retired - No Coverage"
    note2 = "All Parts & Labor"
'
    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
'
        With oLo
'
            For l = 1 To .ListRows.Count
                If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
                    .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note1
                End If
'
                If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
                    .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note2
                End If
            Next
        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
            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
'
        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
End Sub
 
Upvote 0
johnnyL said:
Few more changes:

VBA Code: 
Sub AscCSFormat()
'
       Application.Calculation = xlManual
    Application.ScreenUpdating = False
      Application.EnableEvents = False
'
    Dim oLo             As ListObject
    Dim l               As Long, LastColumn As Long, WorkSheetNumber    As Long
    Dim f               As Range, hdr       As Range, r                 As Range
    Dim cell            As String, note1    As String, note2            As String
'
'---------------------------------------------------------------------------------------------------------------------
'
    note1 = "Retired - No Coverage"
    note2 = "All Parts & Labor"
'
    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
'
        With oLo
'
            For l = 1 To .ListRows.Count
                If .ListColumns("Transaction Type").DataBodyRange(l, 1).Value = "Retirement" Then
                    .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note1
                End If
'
                If .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = "Missing Coverage" Then
                    .ListColumns("TriMedx Coverage").DataBodyRange(l, 1).Value = note2
                End If
            Next
        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
            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
'
        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
End Sub
Click to expand...
Thanks for the huge help! I believe the majority of the macro is being spent with the loops (i = 1 and l =1) to find the different criteria's but have already came a long way from where this code originally was! Just gotta keep figuring out/learning new ways to make the macro as efficient as possible!
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
A little VBA/Macro code adjustment
Replies
3
Views
279
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
263
NUC_N_FUTS2
N
I
  • Question Question
Apply delay before running code
Replies
8
Views
248
ipbr21054
I
I
  • Solved
Simplify my working code please
Replies
7
Views
166
ipbr21054
I

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

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