One for the coding experts - Locate the error in my subtotal macro?

MarathonZephead

New Member
Joined
Oct 25, 2013
Messages
36
Hello

I was kindly given the code below 11 years ago by a very kind member of the board whom I've lost contact with, and it's stopped producing the right result and I can't figure out why.

The code runs when I click a custom button and inserts 3 rows where the selected cell is. The first row is subtotals, the second row ranks the subtotals and the third row is data copied from row 369. When I click the button again, the 3 rows are deleted.

I can't figure out why the subtotals always show zero, even though the formula shown in each of the subtotal cells shows the correct function and range.

Here's the code:

Code:
'Main macro courtesy of Florante Kho 2003
'Progress Timer courtesy of Justin Labenne 10.2005
Sub YTDSubtotals()
Dim PB As clsDailyTrackingProgressBar
Dim nCounter As Integer
Dim lWaitCount As Long

Set PB = New clsDailyTrackingProgressBar

With PB
    .Title = "Daily Tracking YTD Mileage Subtotals"
    .Caption1 = "Working..."
    .Caption2 = "Please wait..."
    .Show
        '-----------------------
        .Progress = 5
        .Caption3 = "Completed " & (CStr(5) & "%")
        '-----------------------
Dim AddRange, Add1stCell As String
Dim Maxcol As Integer
Dim Currcell As Range
On Error Resume Next
Set Currcell = ActiveCell
Worksheets("Daily Tracking").Activate
Application.ScreenUpdating = False
Application.EnableEvents = False
    Dim Restoring As Boolean
        
        Maxcol = Range("A1:CF1").Find(Year(Now())).Column
        Range("A2:A368").Find("Subtot").EntireRow.Delete
        Range("A2:A368").Find("Rank").EntireRow.Delete
        Range("A2:A368").Find("Year").EntireRow.Delete
        If Err = 0 Then
            Restoring = True
        Else
            Restoring = False
        End If
        
        If Not (Restoring) And ActiveCell.Row < 370 Then 'to prevent from adding extra row when there is no date in the column A
            Rows(ActiveCell.Row).Insert Shift:=xlDown
            Range("A" & ActiveCell.Row).Value = "SUBTOT"
            AddRange = Replace(Range("B2:B" & ActiveCell.Row - 1).Address, "$", "")
            Range("B" & ActiveCell.Row) = "=SUM(" & AddRange & ")"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FillRight
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).Font.Bold = True
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).NumberFormat = "0"
            Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, Maxcol)).Interior.ColorIndex = 35
        
'Address for the cell to have conditional formating
            add1 = Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).Address
'Remove any prior formating
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Delete
'Condition 1
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                Formula1:="=LARGE(" & add1 & ",1)"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(1).Font.ColorIndex = 44
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(1).Interior.ColorIndex = 1
'Condition 2
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                Formula1:="=LARGE(" & add1 & ",2)"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(2).Font.ColorIndex = xlAutomatic
   
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(2).Interior.ColorIndex = 15
'Condition 3
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                Formula1:="=LARGE(" & add1 & ",3)"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(3).Font.ColorIndex = xlAutomatic
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(3).Interior.ColorIndex = 40

        '-----------------------
        .Progress = 25
        .Caption3 = "Completed " & (CStr(25) & "%")
        '-----------------------
        
'Move one row down
            ActiveCell.Offset(1, 0).Select
            Rows(ActiveCell.Row).Insert Shift:=xlDown
            Range("A" & ActiveCell.Row) = "RANK"

'Address of the cell to have conditional formating
            AddRange = Range(Cells(ActiveCell.Row - 1, 2), Cells(ActiveCell.Row - 1, Maxcol)).Address

        '-----------------------
        .Progress = 50
        .Caption3 = "Completed " & (CStr(50) & "%")
        '-----------------------

'Address of the 1st cell to have conditional formating
            Add1stCell = Replace(Range(Cells(ActiveCell.Row - 1, 2), Cells(ActiveCell.Row - 1, 2)).Address, "$", "")
            Range("B" & ActiveCell.Row) = "=RANK(" & Add1stCell & "," & AddRange & ",0)"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FillRight

'Remove prior format conditioning
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Delete
        
        '-----------------------
        .Progress = 75
        .Caption3 = "Completed " & (CStr(75) & "%")
        '-----------------------

'1st condition
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
            Formula1:="1"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(1).Interior.ColorIndex = 1
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(1).Font.ColorIndex = 44

'2nd condition
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
            Formula1:="2"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(2).Interior.ColorIndex = 15
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(2).Font.ColorIndex = xlAutomatic

'3rd condition
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
            Formula1:="3"
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(3).Interior.ColorIndex = 40
            Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, Maxcol)).FormatConditions(3).Font.ColorIndex = xlAutomatic
            ActiveCell.Offset(-1, 0).Activate
'Moves the cursor up 1 row - the '0' instructs the cursor to remain within the same column

'==========End new row =============
            ActiveCell.Offset(2, 0).Activate
            Rows(ActiveCell.Row).Insert Shift:=xlDown
            Range(Cells(1, 1), Cells(1, Maxcol)).Copy
            Range("A" & ActiveCell.Row).PasteSpecial xlPasteValues
            Range("A" & ActiveCell.Row).PasteSpecial xlPasteFormats
            Range("A" & ActiveCell.Row) = "YEAR"
            
'==========Start new row =============
            Application.CutCopyMode = False
            Currcell.Activate
            ActiveCell.Offset(-3, 0).Activate
            
        '-----------------------
            .Progress = 100
            .Caption3 = "Completed " & (CStr(100) & "%")
        '-----------------------

        End If
Application.ScreenUpdating = True
Application.EnableEvents = True
            If UserCancelled = True Then GoTo EndRoutine
               
EndRoutine:
    .Finish
   
End With
Set PB = Nothing

End Sub

Many thanks!
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

Watch MrExcel Video

Forum statistics

Threads
1,122,232
Messages
5,594,956
Members
413,954
Latest member
mrsandy

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
Top