Optimization Possible for Calculated Subtotal Insertion VBA?

A

Aimee S.

Board Regular
Joined
Sep 28, 2010
Messages
236
Office Version
  1. 365
Platform
  1. Windows
Hello Folks!

So I have this wonderful file that organizes project process by state / company, and one of the macros I run that I had assistance putting together a while back inserts calculated subtotal rows on every individual State's worksheet. The only problem is that it takes 12 minutes to run. :( Am I just stuck due to the large number of worksheets in this file? Anything at all I can do to optimize? All suggestions welcome.

Code: 
Option Explicit

Sub NEW_Insert_Sub_Totals_And_Sub_Averages()


    UserForm1.Show
    Dim ws As Variant
    Dim LR As Long, LR1 As Long, LC As Long
    Dim r As Range
    Dim myRow As Long, Start As Long, lLoop As Long
    Dim rFoundCell As Range


    Dim xlCalc As XlCalculation


    On Error GoTo ExitPoint
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


    Start = 4


    For Each ws In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX", "Prior AL", "Prior AZ", "Prior CA", "Prior CO", "Prior FL", "Prior GA", "Prior ID", "Prior IN", "Prior KY", "Prior ME", "Prior MI", "Prior MN", "Prior MS", "Prior NH", "Prior NY", "Prior OH", "Prior OK", "Prior PA", "Prior SC", "Prior TN", "Prior VA", "Prior VT", "Prior WA", "Prior WI", "Prior XX")
        Set ws = Sheets(ws)
        With ws
            .Activate
            .Range("A4:BF500").Select
            Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(12, 13, 14, 20, 21, 23, 24 _
                        , 25, 26, 27, 28, 29, 30, 31, 32), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
                        True
            myRow = .Columns("H").Find(What:="Grand*", LookIn:=xlValues, LookAt:=xlPart).Row
            .Range("A" & myRow).EntireRow.Delete


            With .Columns(8)
                Set rFoundCell = .Cells(1, 1)
                For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "*Total*")
                    Set rFoundCell = .Find(What:="*Total*", After:=rFoundCell, _
                                           LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, MatchCase:=False)
                    ws.Cells(rFoundCell.Row, "BE").Formula = "=SubTotal(1,BE" & Start & ":BE" & rFoundCell.Row - 1 & ")"
                    Start = rFoundCell.Row + 1
                Next lLoop
            End With
            Start = 4
            ws.Range("A4").Select
        End With
    Next ws
    Call NEW_Reset_Formatting
ExitPoint:
    With Application
        .Calculation = xlCalc
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
Unload UserForm1
    Sheets("AL").Select
    Range("K4").Select
    Sheets("AZ").Select
    Range("K4").Select
    Sheets("CA").Select
    Range("K4").Select
    Sheets("CO").Select
    Range("K4").Select
    Sheets("FL").Select
    Range("K4").Select
    Sheets("GA").Select
    Range("K4").Select
    Sheets("ID").Select
    Range("K4").Select
    Sheets("IN").Select
    Range("K4").Select
    Sheets("KY").Select
    Range("K4").Select
    Sheets("ME").Select
    Range("K4").Select
    Sheets("MI").Select
    Range("K4").Select
    Sheets("MN").Select
    Range("K4").Select
    Sheets("MS").Select
    Range("K4").Select
    Sheets("NH").Select
    Range("K4").Select
    Sheets("NY").Select
    Range("K4").Select
    Sheets("OH").Select
    Range("K4").Select
    Sheets("OK").Select
    Range("K4").Select
    Sheets("PA").Select
    Range("K4").Select
    Sheets("SC").Select
    Range("K4").Select
    Sheets("TN").Select
    Range("K4").Select
    Sheets("VA").Select
    Range("K4").Select
    Sheets("VT").Select
    Range("K4").Select
    Sheets("WA").Select
    Range("K4").Select
    Sheets("WI").Select
    Range("K4").Select
    Sheets("XX").Select
    Range("K4").Select
    Call DeleteRows520OnwardforEachStateToManageFileSize
    Sheets("Control Panel").Select
End Sub
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Aimee S.,

Made a few tweaks... mostly commenting out the .Activate or .Select methods which really slows code execution.

Code: 
Sub NEW_Insert_Sub_Totals_And_Sub_Averages()

    UserForm1.Show
    Dim ws As Variant
    Dim LR As Long, LR1 As Long, LC As Long
    Dim r As Range
    Dim myRow As Long, Start As Long, lLoop As Long
    Dim rFoundCell As Range

    Dim xlCalc As XlCalculation

    On Error GoTo ExitPoint
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Start = 4

    For Each ws In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX", "Prior AL", "Prior AZ", "Prior CA", "Prior CO", "Prior FL", "Prior GA", "Prior ID", "Prior IN", "Prior KY", "Prior ME", "Prior MI", "Prior MN", "Prior MS", "Prior NH", "Prior NY", "Prior OH", "Prior OK", "Prior PA", "Prior SC", "Prior TN", "Prior VA", "Prior VT", "Prior WA", "Prior WI", "Prior XX")
        Set ws = Sheets(ws)
        With ws
'            .Activate
'            .Range("A4:BF500").Select
            .Range("A4:BF500").Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(12, 13, 14, 20, 21, 23, 24 _
                        , 25, 26, 27, 28, 29, 30, 31, 32), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
                        True
            myRow = .Columns("H").Find(What:="Grand*", LookIn:=xlValues, LookAt:=xlPart).Row
            .Range("A" & myRow).EntireRow.Delete

            With .Columns(8)
                Set rFoundCell = .Cells(1, 1)
                For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "*Total*")
                    Set rFoundCell = .Find(What:="*Total*", After:=rFoundCell, _
                                           LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, MatchCase:=False)
                    ws.Cells(rFoundCell.Row, "BE").Formula = "=SubTotal(1,BE" & Start & ":BE" & rFoundCell.Row - 1 & ")"
                    Start = rFoundCell.Row + 1
                Next lLoop
            End With
            Start = 4
            ws.Range("K4").Select
        End With
    Next ws
    Call NEW_Reset_Formatting
ExitPoint:
    With Application
        .Calculation = xlCalc
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
Unload UserForm1
'    Sheets("AL").Select
'    Range("K4").Select
'    Sheets("AZ").Select
'    Range("K4").Select
'    Sheets("CA").Select
'    Range("K4").Select
'    Sheets("CO").Select
'    Range("K4").Select
'    Sheets("FL").Select
'    Range("K4").Select
'    Sheets("GA").Select
'    Range("K4").Select
'    Sheets("ID").Select
'    Range("K4").Select
'    Sheets("IN").Select
'    Range("K4").Select
'    Sheets("KY").Select
'    Range("K4").Select
'    Sheets("ME").Select
'    Range("K4").Select
'    Sheets("MI").Select
'    Range("K4").Select
'    Sheets("MN").Select
'    Range("K4").Select
'    Sheets("MS").Select
'    Range("K4").Select
'    Sheets("NH").Select
'    Range("K4").Select
'    Sheets("NY").Select
'    Range("K4").Select
'    Sheets("OH").Select
'    Range("K4").Select
'    Sheets("OK").Select
'    Range("K4").Select
'    Sheets("PA").Select
'    Range("K4").Select
'    Sheets("SC").Select
'    Range("K4").Select
'    Sheets("TN").Select
'    Range("K4").Select
'    Sheets("VA").Select
'    Range("K4").Select
'    Sheets("VT").Select
'    Range("K4").Select
'    Sheets("WA").Select
'    Range("K4").Select
'    Sheets("WI").Select
'    Range("K4").Select
'    Sheets("XX").Select
'    Range("K4").Select
    Call DeleteRows520OnwardforEachStateToManageFileSize
    Sheets("Control Panel").Activate
End Sub

The code calls two other macros which may also be contributing to the poor performance, and the code in the UserForm may be another factor.

Cheers,

tonyyy
 
Last edited:
Upvote 0
Thanks so much, tony :) I did not know that about selects and activates. Yes, I should certainly have posted the other two macros this VBA calls upon. Let me do that and if you see anything else in those macros let me know. Really appreciate your time and help. ^_^

Code: 
Option Explicit

Sub NEW_Reset_Formatting()
    Dim w As Variant
    Dim LR As Long
    Dim c As Variant
    Dim c2 As Range
    Dim Cell As Range
    Dim Priorws As Worksheet
    ' ----------------------------------------------------------------------------------------
    For Each w In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX")
        Set Priorws = Sheets("Prior " & w)
        With Sheets(w)
            LR = .Range("G" & .Rows.Count).End(xlUp).Row + 1
            On Error GoTo ErrHandler
            ' Disable Events:
            Application.EnableEvents = False
            ' Delete All Conditional Formatting Rules In Sheet:
            .Cells.FormatConditions.Delete
            ' Recreate All The Conditional Formatting Rules:
            With .Cells(1, 1).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                                                   "=A1<>'Prior " & .Name & "'!A1")
                .Interior.Color = RGB(255, 211, 167)
                .Font.Color = RGB(0, 51, 153)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                                                   "=COUNTIF(1:1,""*Total*"")")
                .Interior.Color = RGB(220, 230, 241)
                .Font.Color = RGB(31, 73, 125)
                .Font.FontStyle = "Bold Italic"
                .SetFirstPriority
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Green""")
                .Interior.Color = RGB(0, 255, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Yellow""")
                .Interior.Color = RGB(255, 255, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Red""")
                .Interior.Color = RGB(255, 0, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            ' Modify the "Applies To" Ranges:
            .Cells.FormatConditions(1).ModifyAppliesToRange Range("A4:BF500")
            .Cells.FormatConditions(2).ModifyAppliesToRange Range("A4:BF500")
            .Cells.FormatConditions(3).ModifyAppliesToRange Range("G4:G500")
            .Cells.FormatConditions(4).ModifyAppliesToRange Range("G4:G500")
            .Cells.FormatConditions(5).ModifyAppliesToRange Range("G4:G500")
            
            .Range("A4:BF500").ClearComments
            For Each c In .Range("A4:BF500")
                Set c2 = Priorws.Range(c.Address)
                If c.Value <> c2.Value Then
                    With c.AddComment
                        .Text Text:="Was: " & WorksheetFunction.Text(c2.Value, c.NumberFormat)
                        .Shape.TextFrame.Characters.Font.Size = 10
                        .Shape.TextFrame.Characters.Font.Name = "Khmer UI"
                        .Shape.TextFrame.AutoSize = True
                    End With
                End If
            Next c
        End With
    Next w
    
ErrHandler:
    Application.EnableEvents = True
    Worksheets("Control Panel").Activate
    Range("A1").Select
End Sub

and


Code: 
Sub DeleteRows520OnwardforEachStateToManageFileSize()
'
' DeleteRows520OnwardforEachStateToManageFileSize Macro
'
'
    Sheets("AL").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior AL").Visible = True
    Sheets("Prior AL").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("AZ").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior AZ").Visible = True
    Sheets("Prior AZ").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("CA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior CA").Visible = True
    Sheets("Prior CA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("CO").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior CO").Visible = True
    Sheets("Prior CO").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("FL").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior FL").Visible = True
    Sheets("Prior FL").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("GA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior GA").Visible = True
    Sheets("Prior GA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("ID").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior ID").Visible = True
    Sheets("Prior ID").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("IN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior IN").Visible = True
    Sheets("Prior IN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("KY").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior KY").Visible = True
    Sheets("Prior KY").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("ME").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior ME").Visible = True
    Sheets("Prior ME").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("MI").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior MI").Visible = True
    Sheets("Prior MI").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("MN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior MN").Visible = True
    Sheets("Prior MN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("MS").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior MS").Visible = True
    Sheets("Prior MS").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("NH").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior NH").Visible = True
    Sheets("Prior NH").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("NY").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior NY").Visible = True
    Sheets("Prior NY").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("OH").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior OH").Visible = True
    Sheets("Prior OH").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("OK").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior OK").Visible = True
    Sheets("Prior OK").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("PA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior PA").Visible = True
    Sheets("Prior PA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("SC").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior SC").Visible = True
    Sheets("Prior SC").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("TN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior TN").Visible = True
    Sheets("Prior TN").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("VA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior VA").Visible = True
    Sheets("Prior VA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("VT").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior VT").Visible = True
    Sheets("Prior VT").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("WA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior WA").Visible = True
    Sheets("Prior WA").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("WI").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior WI").Visible = True
    Sheets("Prior WI").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    Sheets("XX").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    Sheets("Prior XX").Visible = True
    Sheets("Prior XX").Select
    Rows("520:5020").Select
    Selection.Delete Shift:=xlUp
    Range("K4").Select
    ActiveWindow.SelectedSheets.Visible = False
    '
    
    '
    Calculate
    ActiveWorkbook.Save
    
End Sub
 
Upvote 0
Oh... please make the following edit/addition:

Code: 
'            ws.Range("K4").Select
            Application.Goto .Range("K4")

Otherwise there'll be an error.
 
Upvote 0
So, the DeleteRows520... macro can be condensed to two lines, which I've added to the NEW_Reset_Formatting macro.

Code: 
        .Rows("520:5020").Delete Shift:=xlUp
        Priorws.Rows("520:5020").Delete Shift:=xlUp

Also commented out the Call DeleteRows510... statement on the main macro.

Including the entire code below so as to avoid individual line editing errors.

Code: 
Sub NEW_Insert_Sub_Totals_And_Sub_Averages()

    UserForm1.Show
    Dim ws As Variant
    Dim LR As Long, LR1 As Long, LC As Long
    Dim r As Range
    Dim myRow As Long, Start As Long, lLoop As Long
    Dim rFoundCell As Range

    Dim xlCalc As XlCalculation

    On Error GoTo ExitPoint
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Start = 4

    For Each ws In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX", "Prior AL", "Prior AZ", "Prior CA", "Prior CO", "Prior FL", "Prior GA", "Prior ID", "Prior IN", "Prior KY", "Prior ME", "Prior MI", "Prior MN", "Prior MS", "Prior NH", "Prior NY", "Prior OH", "Prior OK", "Prior PA", "Prior SC", "Prior TN", "Prior VA", "Prior VT", "Prior WA", "Prior WI", "Prior XX")
        Set ws = Sheets(ws)
        With ws
'            .Activate
'            .Range("A4:BF500").Select
            .Range("A4:BF500").Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(12, 13, 14, 20, 21, 23, 24 _
                        , 25, 26, 27, 28, 29, 30, 31, 32), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
                        True
            myRow = .Columns("H").Find(What:="Grand*", LookIn:=xlValues, LookAt:=xlPart).Row
            .Range("A" & myRow).EntireRow.Delete

            With .Columns(8)
                Set rFoundCell = .Cells(1, 1)
                For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "*Total*")
                    Set rFoundCell = .Find(What:="*Total*", After:=rFoundCell, _
                                           LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, MatchCase:=False)
                    ws.Cells(rFoundCell.Row, "BE").Formula = "=SubTotal(1,BE" & Start & ":BE" & rFoundCell.Row - 1 & ")"
                    Start = rFoundCell.Row + 1
                Next lLoop
            End With
            Start = 4
'            ws.Range("K4").Select
            Application.Goto .Range("K4")
        End With
    Next ws
    Call NEW_Reset_Formatting
ExitPoint:
    With Application
        .Calculation = xlCalc
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
Unload UserForm1
'    Sheets("AL").Select
'    Range("K4").Select
'    Sheets("AZ").Select
'    Range("K4").Select
'    Sheets("CA").Select
'    Range("K4").Select
'    Sheets("CO").Select
'    Range("K4").Select
'    Sheets("FL").Select
'    Range("K4").Select
'    Sheets("GA").Select
'    Range("K4").Select
'    Sheets("ID").Select
'    Range("K4").Select
'    Sheets("IN").Select
'    Range("K4").Select
'    Sheets("KY").Select
'    Range("K4").Select
'    Sheets("ME").Select
'    Range("K4").Select
'    Sheets("MI").Select
'    Range("K4").Select
'    Sheets("MN").Select
'    Range("K4").Select
'    Sheets("MS").Select
'    Range("K4").Select
'    Sheets("NH").Select
'    Range("K4").Select
'    Sheets("NY").Select
'    Range("K4").Select
'    Sheets("OH").Select
'    Range("K4").Select
'    Sheets("OK").Select
'    Range("K4").Select
'    Sheets("PA").Select
'    Range("K4").Select
'    Sheets("SC").Select
'    Range("K4").Select
'    Sheets("TN").Select
'    Range("K4").Select
'    Sheets("VA").Select
'    Range("K4").Select
'    Sheets("VT").Select
'    Range("K4").Select
'    Sheets("WA").Select
'    Range("K4").Select
'    Sheets("WI").Select
'    Range("K4").Select
'    Sheets("XX").Select
'    Range("K4").Select
'    Call DeleteRows520OnwardforEachStateToManageFileSize
    Sheets("Control Panel").Activate
    ActiveWorkbook.Save
End Sub

Code: 
Sub NEW_Reset_Formatting()
    Dim w As Variant
    Dim LR As Long
    Dim c As Variant
    Dim c2 As Range
    Dim Cell As Range
    Dim Priorws As Worksheet
    ' ----------------------------------------------------------------------------------------
    For Each w In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX")
        Set Priorws = Sheets("Prior " & w)
        With Sheets(w)
            LR = .Range("G" & .Rows.Count).End(xlUp).Row + 1
            On Error GoTo ErrHandler
            ' Disable Events:
            Application.EnableEvents = False
            ' Delete All Conditional Formatting Rules In Sheet:
            .Cells.FormatConditions.Delete
            ' Recreate All The Conditional Formatting Rules:
            With .Cells(1, 1).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                                                   "=A1<>'Prior " & .Name & "'!A1")
                .Interior.Color = RGB(255, 211, 167)
                .Font.Color = RGB(0, 51, 153)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                                                   "=COUNTIF(1:1,""*Total*"")")
                .Interior.Color = RGB(220, 230, 241)
                .Font.Color = RGB(31, 73, 125)
                .Font.FontStyle = "Bold Italic"
                .SetFirstPriority
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Green""")
                .Interior.Color = RGB(0, 255, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Yellow""")
                .Interior.Color = RGB(255, 255, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            With .Cells(1, 1).FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, _
                                                   Formula1:="=""Red""")
                .Interior.Color = RGB(255, 0, 0)
                .Font.Color = RGB(0, 0, 0)
            End With
            ' Modify the "Applies To" Ranges:
            .Cells.FormatConditions(1).ModifyAppliesToRange Range("A4:BF500")
            .Cells.FormatConditions(2).ModifyAppliesToRange Range("A4:BF500")
            .Cells.FormatConditions(3).ModifyAppliesToRange Range("G4:G500")
            .Cells.FormatConditions(4).ModifyAppliesToRange Range("G4:G500")
            .Cells.FormatConditions(5).ModifyAppliesToRange Range("G4:G500")
            
            .Range("A4:BF500").ClearComments
            For Each c In .Range("A4:BF500")
                Set c2 = Priorws.Range(c.Address)
                If c.Value <> c2.Value Then
                    With c.AddComment
                        .Text Text:="Was: " & WorksheetFunction.Text(c2.Value, c.NumberFormat)
                        .Shape.TextFrame.Characters.Font.Size = 10
                        .Shape.TextFrame.Characters.Font.Name = "Khmer UI"
                        .Shape.TextFrame.AutoSize = True
                    End With
                End If
            Next c
        End With
        
        .Rows("520:5020").Delete Shift:=xlUp
        Priorws.Rows("520:5020").Delete Shift:=xlUp
        
    Next w
    
ErrHandler:
    Application.EnableEvents = True
    Worksheets("Control Panel").Activate
'    Range("A1").Select
End Sub

Assuming the above works properly - no testing on my part - you can delete the commented lines for better readability.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Populating a ListBox with Columns Using Pre-Filled Array
Replies
5
Views
562
Legacy 143009
L
ivonsurf123
  • Question Question
Update cells and highlight changes based on criteria
Replies
1
Views
299
ivonsurf123
ivonsurf123
P
  • Solved
Calculating shortest to longest distances between Zip Codes (using latitude and longitude)
2 3
Replies
25
Views
2K
pawcoyote
P
S
  • Question Question
VBA Macro Start to finish way to long
Replies
1
Views
3K
jasonb75
J
S
  • Question Question
UDF not working as expected
Replies
2
Views
678
spydey
S

Forum statistics

Threads
1,224,823
Messages
6,181,183
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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