Subtotals cause hang with large data

[9tanstaafl9]

I have a worksheet that uses Excel 2003's automatic subtotalling feature witSelectihin one of my macros. It works fine on my sample data, but when I try to run it on the larger set of customer data it hangs.

Any suggestions? I've been up all night, maybe this is just something really dumb, but I don't know. I stepped thru the macros, and it is hanging when I press f8 for the line that inserts the subtotals.

According to the task manager it really is hung, not just slow. Waited over 2 hours.

The line of code where it is hanging is:
Selection.subtotal groupby:=3, function:=xlsum, totallist:=array(14, 15, 16, 17, 18, 19, 20, 21, 22), Replace:=true, Pagebreaks:=false, Summarybelowdata:=true

I am a total newbie, so if there is a painfully obvious reason for why this is happening, don't think I'll be upset if you point out how dumb I am. Speaking of dumb, if this issue is posted elsewhere I apologize, I searched for hours before asking, but I may have looked in the wrong place.

 

[9tanstaafl9]

Ok, maybe this question is easier... Is there some way to insert rows with subtotals in vba without using the automatic subtotaling feature? I don't need to be able to collapse groups or use any of the filter features.

Basically, I have many rows (around 20,000) of data )with no blank cells in column C), sorted by the code number in columc C. This code number changes after every nine rows. All I want to do is have a macro that will automatically insert a row with sums in a few of the columns that will add up the preceding nine rows. And a grand total at the bottom.

 

[Fazza]

Hi,

It doesn't seem right that the code would take so long. Perhaps something else is the problem?

Seeing "Selection" makes me wonder as to the efficiency of the code.

How long does it take to manually (without code) insert the subtotals?

It is unlikely that code can be written to put in the subtotals any better than the built in auto subtotalling. Maybe pursue another route, if suitable, such as a pivot table?

HTH, Fazza

 

[9tanstaafl9]

Thank you for answering. The code is what I got when I used the recorder to insert the subtotals. I'm still a newbie, so I was using that to steal the code from. If there's a smarter way to do it please tell me.

Before I changed my macros to include the subtotalling, it ran in about 15 seconds. After subtotalling it took about 80 seconds using my sample data. When I switched to the customer's data, it won't run at all. It looks like it's running, and I see some of the steps of my macro happening, but when it gets to the insert subtotals, it appears to do nothing for a long time (like 10 minutes or so) and then a blue bar appears (sometimes) down the left side of the screen. We waited over 2 hours and it never worked.

Thinking maybe they had faulty data, I tried using the subtotal feature from the menu command (not using a macro) and it ran in just a few seconds. I stepped thru using f8 and the hang definitely happened on the subtotal insert line.

The subtotals are operating on rows that refer to other sheets in the workbook that are pulling data using Microsoft Query / ODBC. Does that change things?

 

[VoG]

Hi

I'm not sure that I can help directly with this but you really need to post the code that the macro recorder gave you in order to get a definitive answer.

 

[RoryA]

Does your code turn off Events, ScreenUpdating and Calculation before adding the Subtotals and then turn them back on afterwards?

 

[9tanstaafl9]

Does your code turn off Events, ScreenUpdating and Calculation before adding the Subtotals and then turn them back on afterwards?

Thank you. I had turned off calculation already, but not screen updating or events. I will try that, and then I'll post the code as soon as I figure out how. Family time today, so I'll do that tomorrow or later tonight.

 

[9tanstaafl9]

Ok, I tried turning everything off as suggested, and it did run a bit faster, but I am still having problems when running it using a bigger set of data.

FYI: On the lower left of the screen it says "connecting to datasource" for a long period of time, not sure why (I never saw it before I added subtotals to the equation...). The data in the supporting worksheets only need to be updated long BEFORE the subtotals are inserted, so if there is a way to turn that off please let me know.

I am copying my code below. PLEASE be kind, this is my very first VBA project of any kind (I'm halfway thru VBA for Dummies) and the last time I was really good at Excel was in the 80's. Point out any dumb things I can fix, but pls be specific and don't assume I know anything.

The part that appears to be broken (tho I've included everything) is Sub AddSubtotals()


----------------

Sub Start()
Application.Cursor = xlWait
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("Working").Visible = True
Sheets("Projected Costs").Unprotect
ActiveWindow.FreezePanes = False
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = off
End If
Rows("14:16").EntireRow.Hidden = False
End Sub

Sub Everything()
Worksheets("Cost Codes").Select
Range("A1").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Worksheets("Projected Costs").Select
Application.Run "Start"
ActiveWorkbook.RefreshAll
'don't need to remove subtotals for Change Job, _
fix this after other issues are resolved.
Application.Run "RemoveSubtotals"
Application.Run "CopyCostCodes"
Application.Run "FindDuplicates"
Application.Run "TransferCodes"
Application.Run "FillFormulas"
Application.Run "SortAll"
Application.Run "KillBlanks"
Application.Run "UnlockInputColumns"
Application.Run "MakeNames1"
Application.Run "AddSubtotals"
Application.Run "FormatTotalRows"
Application.Run "MakeNames2"
Application.Run "Finish"
End Sub

Sub CopyCostcodes()
Sheets("Working").Cells.Clear
Sheets("Cost Codes").Select
Range("B2").Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Pastes 9 times
Sheets("Working").Select
Range("a1").Select
ActiveSheet.Paste
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False

Selection.CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Insert Shift:=xlToRight
Columns("A:A").Insert Shift:=xlToRight
Range("C1").End(xlDown).Offset(0, -1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Name = "AreaToFill"

Range("b1") = 1
Range("b2") = 2
Range("b3") = 3
Range("b4") = 4
Range("b5") = 5
Range("b6") = 6
Range("b7") = 7
Range("b8") = 8
Range("b9") = 9
Range("B1:B9").AutoFill Destination:=Range("AreaToFill"), Type:=xlFillCopy

End Sub

Sub FindDuplicates()
Sheets("Projected Costs").Select
Range("C15").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Working").Select
Range("H1").Select
ActiveSheet.Paste
Range("G1").FormulaR1C1 = "=MATCH(RC[-4],C[1],0)"
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 4).FillDown
ActiveSheet.Calculate
On Error GoTo Error_Exception
Selection.SpecialCells(xlCellTypeFormulas, 16).EntireRow.Copy
Error_Exception:
End Sub

Sub TransferCodes()
Sheets("Projected Costs").Select
Rows("16").Select
Selection.Insert Shift:=xlDown
If Range("B16") < 1 Then
Rows("16:16").Select
Selection.Delete Shift:=xlUp
End If
End Sub

Sub FillFormulas()
Range("E15").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 27).Select
Selection.FillDown
Selection.Resize(NUMROWS - 1, numColumns + 1).Offset(0, 29).Select
Selection.FillDown
Selection.Resize(NUMROWS - 1, numColumns + 3).Offset(0, 3).Select
Selection.FillDown
End Sub

Sub KillBlanks()
On Error GoTo ErrorHandler:
Range("AI15").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 0).Offset(0, 1). _
SpecialCells(xlCellTypeBlanks).Value = 0
Selection.Resize(NUMROWS - 1, numColumns + 0).Offset(0, -2). _
SpecialCells(xlCellTypeBlanks).Value = 0

ErrorHandler:
Columns("AJ:AJ").NumberFormat = "#,##0.00_);[Red](#,##0.00);"" - """
Columns("Ag:Ag").NumberFormat = "#,##0.00_);[Red](#,##0.00);"" - """
End Sub

Sub SortAll()
Range("D15").Select
Range(Selection, Selection.End(xlDown)).EntireRow.Select
Selection.Sort Key1:=Range("C15"), Order1:=xlAscending, Key2:=Range("B15" _
), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal
End Sub

Sub MakeNames1()
Range("b17").Select
Range(Selection, Selection.End(xlDown)).Select
ThisWorkbook.Names.Add Name:="COLE", _
RefersTo:="=" & Selection.Address()

Range("AL17").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 0).Select
ThisWorkbook.Names.Add Name:="PROJ", _
RefersTo:="=" & Selection.Address()
End Sub

Sub MakeNames2()
Range("D17").Select
Selection.End(xlDown).Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, -1).Range("A1").Select
ThisWorkbook.Names.Add Name:="TPC", _
RefersTo:="=" & Selection.Address()

ActiveCell.Offset(0, -23).Range("A1").Select
ThisWorkbook.Names.Add Name:="OB", _
RefersTo:="=" & Selection.Address()
End Sub

Sub RemoveSubtotals()
Range("D17").Select
Range(Selection, Selection.End(xlDown)).EntireRow.Select

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Selection.RemoveSubtotal

'trying leaving these off...
Application.EnableEvents = True
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic

'why is this here, check later
Range("C17").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:=ActiveCell.Offset(-2, 2).Range("A1"), Order1:= _
xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

End Sub

Sub AddSubtotals()
Application.DisplayAlerts = False 'had to add this to make sure they don't choose wrong thing and screw up macro - eventually need to figure out why it pops up in the first place
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("B16:Ao16").Select
Range(Selection, Selection.End(xlDown)).Select

'turning off events because someone suggested it on Mr. Excel, I have no idea if this is what they meant exactly, or what it does, just trying anything at this point...
Application.EnableEvents = False
'this is the part I stole form the macro recorder... don't know how to do it otherwise, maybe a better way
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38), Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
Application.EnableEvents = True

'fixes filter for subtotal lines
Range("d17").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(0, 36).FillDown
Range("AN15", "AN17").FillDown

End Sub

Sub FormatTotalRows()
Range("C17").Select
Selection.CurrentRegion.Select

Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Total" Then
Rows(rCell.Row).Interior.ColorIndex = 36
Rows(rCell.Row).Locked = True

End If
If Right(rCell.Value, 11) = "Grand Total" Then
Rows(rCell.Row).Interior.ColorIndex = 44
End If
Next
End Sub

Sub Refresh()
Application.Run "Everything"
End Sub

Sub Finish()
Sheets("Working").Visible = False
Rows("14:16").EntireRow.Hidden = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'trying to delete, see if works
Worksheets("Projected Costs").Unprotect
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True
Application.Cursor = xlDefault
Range("c1").Select
End Sub


-----------------------------

I apologize for posting something so long, but since I may have screwed up anywhere along the way, I thought it might matter. The part where it seems to be hanging is the module Add Subtotals()

 

[RoryA]

Application.DisplayAlerts = False 'had to add this to make sure they don't choose wrong thing and screw up macro - eventually need to figure out why it pops up in the first place

What was popping up originally? Are you trying to add subtotals to a range returned from an external data source?

 

[9tanstaafl9]

I'm not sure what you mean by "range returned from an external data source". Maybe. I have an external data source (my husband wrote queries using ODBC and a foxpro driver -- i really don't know what that means) to pull data into several worksheets in this workbook. I am subtotalling rows on sheet 1 (Projected Costs) that have SOME fields getting their info from the supporting worksheets, and some fields which will be manually entered, and some which are just calculations of other fields in the row.

Basically, what I want to have happen is for the macro to run, pull in any new data from the external source, sort and subtotal it by cost code, then filter out the rows that have no costs (there is a filter applied to all of this after the subtotalling part of the macro runs). At the point the subtotal is applied, there is absolutely no reason for it to have to check the external data source again.

What was popping up originally? Are you trying to add subtotals to a range returned from an external data source?