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:
It shows the sheet name as Macros?
Click to expand...
So my macros are held in a file called Master Macros and this sheet contains all of the macros I have been working on. This sheet opens on startup for Excel (hidden). I think when I try to run this code thats in my Master Macros Workbook on my regular file it runs it from Master Macros Workbook and not from my Regular File hence why it tries to reference "Macros" as ws.Name since that is the Sheet name in Master Macros Workbook...

Trying to make sense of it all but I thought I would be able to run the code - regardless of where the code sits?
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
bmkelly said:
It shows the sheet name as Macros?
Click to expand...
now you know why it didn't do anything for that sheet.

bmkelly said:
(although I am seeing quite a few blank rows with coverage - not sure if thats part of the original file or not though)
Click to expand...
not sure what that means, but if it's the TriMedx Coverage column you're talking about,
your original data filters to 30 of 2266 records found for blanks.
16 are Total rows and 14 are rows where your Annual Service Price cells are not formatted the same as the rest of the column.

bmkelly said:
regardless of where the code sits?
Click to expand...
Did I miss this being mentioned previously?
 
Upvote 0
NoSparks said:
now you know why it didn't do anything for that sheet.
Click to expand...
Yeah, it seems to run on the original file when I would run Johnny's macro so I guess I just never caught it until I ran your macro.
NoSparks said:
not sure what that means, but if it's the TriMedx Coverage column you're talking about,
your original data filters to 30 of 2266 records found for blanks.
16 are Total rows and 14 are rows where your Annual Service Price cells are not formatted the same as the rest of the column.
Click to expand...
That is on me, this is a file of another analyst (as I do not have any sites that have this formatting but I am trying to help our department out with automating some of our work, so I had a feeling it had to do with the original file and not with anything you all have coded)
NoSparks said:
Did I miss this being mentioned previously?
Click to expand...
No, I don't think this was stated in this post (it was in a different post of mine) but kind of like I said just above, I didn't catch that since I was running Johnny's macro which ran fine in my Original File even though the macro is held in a Master Macros file.
 
Upvote 0
NoSparks said:
now you know why it didn't do anything for that sheet.


not sure what that means, but if it's the TriMedx Coverage column you're talking about,
your original data filters to 30 of 2266 records found for blanks.
16 are Total rows and 14 are rows where your Annual Service Price cells are not formatted the same as the rest of the column.


Did I miss this being mentioned previously?
Click to expand...
Also for the sake of your code - I went and put the code in the Regular file and ran it and it ran perfectly fine on all 3 Transaction Sheets, I think the final step here would be allowing me to run this code from my Master Macros Workbook.

A little history - we need to have our macros in an overall file that will open (hidden) for users in the background because we have so many different templates due to such variety with things that I figured (after doing some research and posts on here) the best route was to make a Master file hidden and run macros from there via Ribbon Shortcut on each individuals Excel.

My apologies for not making this clear from the beginning. Not just on this code, but you have helped me out tremendously on multiple posts of mine and ultimately they actually all end up on this final step we are currently working on now. Ideally, once we get this to finally work, I will then take this code and cut it down some to my template as its not as complex with multiple transaction sheets and utilize that as well!
 
Upvote 0
Sorry, I should have picked up on that when the file you supplied was .xlsx
try changing
VBA Code: 
For Each ws In ThisWorkbook.Worksheets
to
VBA Code: 
For Each ws In ActiveWorkbook.Worksheets
 
Upvote 0
NoSparks said:
Sorry, I should have picked up on that when the file you supplied was .xlsx
try changing
VBA Code: 
For Each ws In ThisWorkbook.Worksheets
to
VBA Code: 
For Each ws In ActiveWorkbook.Worksheets
Click to expand...
No worries, I know this has been probably more than a headache itself....I had changed that part before your post and ran it successfully!

Due to me having OCD, I did add this code before the 'End If Next WS' Code so it adds the Filter back on Row 1 (Headers):
VBA Code: 
 'Add Filter Option'
        ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
        Selection.AutoFilter

I then I attempted (what I thought would be a simple code) to add this after my Filter code above:
VBA Code: 
'Select A1'
        ActiveSheet.Range("A1").Select
So it could select Cell A1 when done with the sheet but it seems to not do that for me since I still have to scroll up and left to get to A1 on the Transaction Sheets

Here is the entire code:
VBA Code: 
Option Explicit
Sub AscCSFormatNS()

'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
          
'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 Table'
        Set oLo = ws.ListObjects(1)
            End With
        
'Sort Table'
        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

'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'
        ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
        Selection.AutoFilter
'Select A1'
        ActiveSheet.Range("A1").Select
        
        End If
        Next ws
       
    Application.Goto Sheets("Cover Page").Range("O1")

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

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

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

End Sub
 
Upvote 0
bmkelly said:
No worries, I know this has been probably more than a headache itself....I had changed that part before your post and ran it successfully!

Due to me having OCD, I did add this code before the 'End If Next WS' Code so it adds the Filter back on Row 1 (Headers):
VBA Code: 
 'Add Filter Option'
        ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
        Selection.AutoFilter

I then I attempted (what I thought would be a simple code) to add this after my Filter code above:
VBA Code: 
'Select A1'
        ActiveSheet.Range("A1").Select
So it could select Cell A1 when done with the sheet but it seems to not do that for me since I still have to scroll up and left to get to A1 on the Transaction Sheets

Here is the entire code:
VBA Code: 
Option Explicit
Sub AscCSFormatNS()

'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
         
'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 Table'
        Set oLo = ws.ListObjects(1)
            End With
       
'Sort Table'
        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

'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'
        ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
        Selection.AutoFilter
'Select A1'
        ActiveSheet.Range("A1").Select
       
        End If
        Next ws
      
    Application.Goto Sheets("Cover Page").Range("O1")

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

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

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

End Sub
Click to expand...
correction it does in fact look like it selects cell A1, I just still have to scroll up and left haha

Overall though- thank you both for the huge help!
 
Upvote 0
Code so it adds the Filter back on Row 1 (Headers):
Click to expand...
I would have use this because it will always be the same thing whereas with Selection you got to be too mindful of what is currently selected.
This way it doesn't matter. This is actually a toggle that turns the filter arrows on and off.
VBA Code: 
 'Add Filter Option'
        oLo.HeaderRowRange.AutoFilter

I just still have to scroll up and left
Click to expand...
try
VBA Code: 
'Select A1'
        ActiveSheet.Range("A1").Select
        Application.Goto ActiveSheet.Range("A1"), True

I know this has been probably more than a headache
Click to expand...
Hell NO, this old retired guy has enjoyed it, gotta do something to keep entertained and the mind active. :)

PS: please change the answer post to #33, as that post is the code used and will always be here, whereas the file linked to will eventually disappear and future forum searchers will be PO'd
Thanks
 
Upvote 0
NoSparks said:
I would have use this because it will always be the same thing whereas with Selection you got to be too mindful of what is currently selected.
This way it doesn't matter. This is actually a toggle that turns the filter arrows on and off.
VBA Code: 
 'Add Filter Option'
        oLo.HeaderRowRange.AutoFilter
Click to expand...
Perfect! This worked!
NoSparks said:
try
VBA Code: 
'Select A1'
        ActiveSheet.Range("A1").Select
        Application.Goto ActiveSheet.Range("A1"), True
Click to expand...
This worked as well! Thanks
NoSparks said:
Hell NO, this old retired guy has enjoyed it, gotta do something to keep entertained and the mind active. :)

PS: please change the answer post to #33, as that post is the code used and will always be here, whereas the file linked to will eventually disappear and future forum searchers will be PO'd
Thanks
Click to expand...
Haha well I already have a minor tweak but I believe I will have to make a new post as its not necessarily related to Running the Code faster....I also believe this isnt the last of my posts on here haha I feel like I have learned quite a bit (especially since i have taken zero classes and all just self taught)
 
Upvote 0
When you do, please post the code that you decided to use as well as the time it takes to complete.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA - button to sort by date in ascending and descending order
Replies
6
Views
375
Peter_SSs
Peter_SSs
I
  • Question
Macro recorded to sort colm,n A-Z so now need to condense it
Replies
4
Views
79
Micron
M
E
  • Solved
ActiveCell vs Active range search
Replies
3
Views
227
Joe4
Joe4
melodramatic
  • Question
VBA - Sort Table in Alternate Workbook
Replies
1
Views
205
melodramatic
melodramatic
Dazzawm
  • Solved
Slight Amendment To Code
Replies
6
Views
292
Dazzawm
Dazzawm

Forum statistics

Threads
1,214,983
Messages
6,122,591
Members
449,089
Latest member
Motoracer88

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