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
johnnyL said:
When you do, please post the code that you decided to use as well as the time it takes to complete.
Click to expand...
Will do! Just waiting on some responses from another post with an update from this code and then I will post the overall code here with the time it takes to complete!
 
Upvote 0

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
johnnyL said:
When you do, please post the code that you decided to use as well as the time it takes to complete.
Click to expand...
For the time being, this is the code I am using:

VBA Code: 
Option Explicit
Sub tAscCSFormat()

'Start Stopwatch'
    Dim startTime As Single
        startTime = Timer

    Dim ws As Worksheet
    Dim oLo As ListObject
    Dim transCol As Long, trimedCol As Long, LastColumn As Long, aspCol As Long, transdteCol As Long, i As Long
    Dim visRng As Range, f As Range, hdr As Range, r As Range
    Dim note1 As String, note2 As String, cell As String
    
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Name Like "*Transactions*" Then
                With ws
                    .Activate
                        On Error Resume Next
                    ws.ShowAllData
                        On Error GoTo 0
                    .Columns.Hidden = False
                    .Rows.Hidden = False
                      
'Set Table'
        Set oLo = ws.ListObjects(1)
            End With
        
'Custom Sort'
        With 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
        
'Change Verbage'
        note1 = "Retired - No Coverage"
        note2 = "All Parts & Labor"
        
'Columns Used 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
                .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
                
'Hide $0 Transactions in Annual Service Price Column'
        .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

'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

'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
            Next

'Remove Page Breaks'
    ActiveSheet.ResetAllPageBreaks

'Set 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
        
'Add Filter Option'
        oLo.HeaderRowRange.AutoFilter
        
'Select A1'
        ActiveSheet.Range("A1").Select
        Application.Goto ActiveSheet.Range("A1"), True
        
        End If
        Next ws
       
    Application.Goto Sheets("Cover Page").Range("O1")

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

Debug.Print "Time to complete = " & Timer - startTime & " seconds."

End Sub

In a different post, I am currently awaiting feedback on how to update
'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

to Autofit from Column Headers 'Customer' to 'Description' like I have in my Regular File that has only one transaction sheet. Outside of that, this code took 11.47 seconds on a file that is 3,333kb in size.

Thank you all for the help, this was a huge step to accomplish!
 
Upvote 0
bmkelly said:
For the time being, this is the code I am using:

VBA Code: 
Option Explicit
Sub tAscCSFormat()

'Start Stopwatch'
    Dim startTime As Single
        startTime = Timer

    Dim ws As Worksheet
    Dim oLo As ListObject
    Dim transCol As Long, trimedCol As Long, LastColumn As Long, aspCol As Long, transdteCol As Long, i As Long
    Dim visRng As Range, f As Range, hdr As Range, r As Range
    Dim note1 As String, note2 As String, cell As String
   
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Name Like "*Transactions*" Then
                With ws
                    .Activate
                        On Error Resume Next
                    ws.ShowAllData
                        On Error GoTo 0
                    .Columns.Hidden = False
                    .Rows.Hidden = False
                     
'Set Table'
        Set oLo = ws.ListObjects(1)
            End With
       
'Custom Sort'
        With 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
       
'Change Verbage'
        note1 = "Retired - No Coverage"
        note2 = "All Parts & Labor"
       
'Columns Used 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
                .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
               
'Hide $0 Transactions in Annual Service Price Column'
        .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

'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

'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
            Next

'Remove Page Breaks'
    ActiveSheet.ResetAllPageBreaks

'Set 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
       
'Add Filter Option'
        oLo.HeaderRowRange.AutoFilter
       
'Select A1'
        ActiveSheet.Range("A1").Select
        Application.Goto ActiveSheet.Range("A1"), True
       
        End If
        Next ws
      
    Application.Goto Sheets("Cover Page").Range("O1")

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

Debug.Print "Time to complete = " & Timer - startTime & " seconds."

End Sub

In a different post, I am currently awaiting feedback on how to update
'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

to Autofit from Column Headers 'Customer' to 'Description' like I have in my Regular File that has only one transaction sheet. Outside of that, this code took 11.47 seconds on a file that is 3,333kb in size.

Thank you all for the help, this was a huge step to accomplish!
Click to expand...
update - new code
time to run - 11.30 seconds

VBA Code: 
Option Explicit
Sub tAscCSFormat()

'Start Stopwatch'
    Dim startTime As Single
        startTime = Timer

    Dim ws As Worksheet
    Dim oLo As ListObject
    Dim transCol As Long, trimedCol As Long, LastColumn As Long, aspCol As Long, transdteCol As Long, i As Long
    Dim visRng As Range, f As Range, hdr As Range, r As Range
    Dim note1 As String, note2 As String, cell As String
    
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Name Like "*Transactions*" Then
                With ws
                    .Activate
                        On Error Resume Next
                    ws.ShowAllData
                        On Error GoTo 0
                    .Columns.Hidden = False
                    .Rows.Hidden = False
                      
'Set Table'
        Set oLo = ws.ListObjects(1)
            End With
        
'Custom Sort'
        With 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
        
'Change Verbage'
        note1 = "Retired - No Coverage"
        note2 = "All Parts & Labor"
        
'Columns Used 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
                .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
                
'Hide $0 Transactions in Annual Service Price Column'
        .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

'Adjust Column Widths'
        Range(Cells(1, oLo.ListColumns("Customer").Range.Column), Cells(1, oLo.ListColumns("Description").Range.Column)).EntireColumn.AutoFit

'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
            Next

'Remove Page Breaks'
    ActiveSheet.ResetAllPageBreaks

'Set 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
        
'Add Filter Option'
        oLo.HeaderRowRange.AutoFilter
        
'Select A1'
        ActiveSheet.Range("A1").Select
        Application.Goto ActiveSheet.Range("A1"), True
        
        End If
        Next ws
       
    Application.Goto Sheets("Cover Page").Range("O1")

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

Debug.Print "Time to complete = " & Timer - startTime & " seconds."

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
A little VBA/Macro code adjustment
Replies
3
Views
262
rollis13
rollis13
A
  • Solved
VBA - button to sort by date in ascending and descending order
Replies
6
Views
1K
Peter_SSs
Peter_SSs
I
  • Question Question
Apply delay before running code
Replies
8
Views
242
ipbr21054
I
I
  • Solved
Simplify my working code please
Replies
7
Views
127
ipbr21054
I
I
  • Question Question
Value not shown in ComboBox1 when code run
Replies
1
Views
37
ipbr21054
I

Forum statistics

Threads
1,223,246
Messages
6,170,996
Members
452,373
Latest member
TimReeks

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