fredlo2010
11-17-2014, 06:05 AM
Hello,
I am working on a code and I wonder how I could solve it. Basically excel is using a lot of my resources until it crashes.
I have a report that comes out of a program with some subtotals and I want to do some formatting on them: Make it bold, insert a row, push it to the side.
I dont want to loop through the whole range because it could be a lot of data; so I looped through the empty cells in the report and added the address to an array and then I am going backwards doing all my modifications. I started from the back to the from the back to the front because I will be adding some extra rows which messes up my for each range loops.
It works as proposed but there is a particular report that crashed; after a lot time trying to figure it out I noticed that excel was using a lot of my memory. There report is long indeed.
Total rows in the report: 274,540
Total Blank rows (aka ubound(subtotals)): 710
This is the code I am using. There are some other procedures here; ignore please I have tested them and everything is ok with them.
Private Sub CashDetail()
Dim lRow As Long
Dim i As Long
Dim r As Range
Dim arrSubTotal() As Variant
' Delete the first extra row
Rows(1).Delete
Call DeleteErrors
Call MoveTotalsCashDetail
' Loop trhough the empty values to create the range array
lRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Preserve arrSubTotal(0)
For Each r In Cells(g_lngROW_DATA, 2).Resize(lRow - g_lngROW_HEADER).SpecialCells(xlCellTypeBlanks)
arrSubTotal(UBound(arrSubTotal)) = r.Address
ReDim Preserve arrSubTotal(UBound(arrSubTotal) + 1)
Next
' Remove the extra bound
ReDim Preserve arrSubTotal(UBound(arrSubTotal) - 1)
' Loop through the arras or ranges from the butom to
' the top and
For i = UBound(arrSubTotal) To LBound(arrSubTotal) Step -1
'''MEMORY BUMP STARTS GROWING WITH EACH ITERATION HERE'''
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Make it bold and offset it.
If Not Range(arrSubTotal(i)).Offset(, -1).Value = vbNullString Then
Range(arrSubTotal(i)).Offset(, -1).Value = vbNullString
Range(arrSubTotal(i)).Resize(, 10).Font.Bold = True
Range(arrSubTotal(i)).Offset(, 3).HorizontalAlignment = xlRight
Range(arrSubTotal(i)).Resize(, 2).Insert Shift:=xlToRight
' If there is another total ontop of it then insert a row.
If Not i = LBound(arrSubTotal) Then
If Range(arrSubTotal(i - 1)).Row = Range(arrSubTotal(i)).Row - 1 Then
Range(arrSubTotal(i)).EntireRow.Insert Shift:=xlDown
End If
End If
End If
Next i
' Extra formattings.
Columns("A").Replace "'", ""
Columns("A").NumberFormat = "mm/dd/yyyy"
Columns("F:I").NumberFormat = "#,##0.00_);[Red](#,##0.00)"
Columns("H:I").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Columns("A:B").HorizontalAlignment = xlCenter
Columns("C:E").HorizontalAlignment = xlLeft
Call FormatHeadings(ActiveSheet, , g_lngROW_HEADER)
Range("A1").Resize(4).HorizontalAlignment = xlLeft
Columns("B:B").ColumnWidth = 14
Columns("E:E").ColumnWidth = 30
Columns("G:F").ColumnWidth = 30
Columns("A:A").ColumnWidth = 25.57
Columns("C:D").EntireColumn.AutoFit
Call FreezePanels("A6")
End Sub
Thanks a lot for the help.
I am working on a code and I wonder how I could solve it. Basically excel is using a lot of my resources until it crashes.
I have a report that comes out of a program with some subtotals and I want to do some formatting on them: Make it bold, insert a row, push it to the side.
I dont want to loop through the whole range because it could be a lot of data; so I looped through the empty cells in the report and added the address to an array and then I am going backwards doing all my modifications. I started from the back to the from the back to the front because I will be adding some extra rows which messes up my for each range loops.
It works as proposed but there is a particular report that crashed; after a lot time trying to figure it out I noticed that excel was using a lot of my memory. There report is long indeed.
Total rows in the report: 274,540
Total Blank rows (aka ubound(subtotals)): 710
This is the code I am using. There are some other procedures here; ignore please I have tested them and everything is ok with them.
Private Sub CashDetail()
Dim lRow As Long
Dim i As Long
Dim r As Range
Dim arrSubTotal() As Variant
' Delete the first extra row
Rows(1).Delete
Call DeleteErrors
Call MoveTotalsCashDetail
' Loop trhough the empty values to create the range array
lRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Preserve arrSubTotal(0)
For Each r In Cells(g_lngROW_DATA, 2).Resize(lRow - g_lngROW_HEADER).SpecialCells(xlCellTypeBlanks)
arrSubTotal(UBound(arrSubTotal)) = r.Address
ReDim Preserve arrSubTotal(UBound(arrSubTotal) + 1)
Next
' Remove the extra bound
ReDim Preserve arrSubTotal(UBound(arrSubTotal) - 1)
' Loop through the arras or ranges from the butom to
' the top and
For i = UBound(arrSubTotal) To LBound(arrSubTotal) Step -1
'''MEMORY BUMP STARTS GROWING WITH EACH ITERATION HERE'''
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Make it bold and offset it.
If Not Range(arrSubTotal(i)).Offset(, -1).Value = vbNullString Then
Range(arrSubTotal(i)).Offset(, -1).Value = vbNullString
Range(arrSubTotal(i)).Resize(, 10).Font.Bold = True
Range(arrSubTotal(i)).Offset(, 3).HorizontalAlignment = xlRight
Range(arrSubTotal(i)).Resize(, 2).Insert Shift:=xlToRight
' If there is another total ontop of it then insert a row.
If Not i = LBound(arrSubTotal) Then
If Range(arrSubTotal(i - 1)).Row = Range(arrSubTotal(i)).Row - 1 Then
Range(arrSubTotal(i)).EntireRow.Insert Shift:=xlDown
End If
End If
End If
Next i
' Extra formattings.
Columns("A").Replace "'", ""
Columns("A").NumberFormat = "mm/dd/yyyy"
Columns("F:I").NumberFormat = "#,##0.00_);[Red](#,##0.00)"
Columns("H:I").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Columns("A:B").HorizontalAlignment = xlCenter
Columns("C:E").HorizontalAlignment = xlLeft
Call FormatHeadings(ActiveSheet, , g_lngROW_HEADER)
Range("A1").Resize(4).HorizontalAlignment = xlLeft
Columns("B:B").ColumnWidth = 14
Columns("E:E").ColumnWidth = 30
Columns("G:F").ColumnWidth = 30
Columns("A:A").ColumnWidth = 25.57
Columns("C:D").EntireColumn.AutoFit
Call FreezePanels("A6")
End Sub
Thanks a lot for the help.