Memory problem (I think ???)

[Guest]

This is a bit verbose but no debugging is required. Both macros work.

The problem is that each time I run the below ApplyFilter macro and then the
RemoveFilter macro, execution becomes progressively slower. It is only
apparent when there is a lot of data being filtered (which is normally the
case). The problem is much worse using xl2002 versus xl2000. When I monitor
the memory usage of Excel.exe through the Task Manager it becomes
progressively larger. When I close and reopen the workbook it reverts to
normal. Note that I take care to destroy the range variables at the end of
each to no avail. Using API code to clear the clipboard and setting
CutCopyMode to False don’t help either. I don't think using Cut with this
syntax involves the clipboard anyway.

There’s a reason I don’t just hide and unhide rows to accomplish filtering
and unfiltering (or use AutoFilter) but I’ll not go into that here. This is
an important part of a large and project so I’m quite concerned. Hoping
someone has encountered this before and has a solution. Very appreciative of
your assisatance.

Sub ApplyFilter(Filter As String, SearchType As String)
Dim rng As Range, rng2 As Range, ar As Range
Dim rw As Long
Dim i As Integer
Dim ScrArea As String

On Error GoTo ProcExit
Filter = Trim(Filter)
Application.ScreenUpdating = False
With MainWks
ScrArea = .ScrollArea
.ScrollArea = ""
With Intersect(.UsedRange, .Range("D:F"))
Set SearchCell = .Find(Filter, LookAt:=LookAtType, MatchCase:=MchCase)
If Not SearchCell Is Nothing Then
rw = SearchCell.Row
If SearchCell(1, 0) = SearchType Then
Set rng = FormatRegion(SearchCell, SheetBackColor)
Set rng2 = rng.Resize(rng.Rows.Count + 3, 33)
End If
Do
Set SearchCell = .FindNext(SearchCell)
If Not SearchCell Is Nothing Then
If SearchCell(1, 0) = SearchType Then
Set rng = FormatRegion(SearchCell, SheetBackColor)
Set rng = rng.Resize(rng.Rows.Count + 3, 33)
If rng2 Is Nothing Then Set rng2 = rng Else Set rng2
= Union(rng2, rng)
End If
Else
Exit Do
End If
Loop While SearchCell.Row > rw
End If
End With
If rng2 Is Nothing Then
Call FailedSearchMsg(1, Filter, SearchType)
Else
With .Range("A2:AF" & .UsedRange.Rows.Count + 1)
.Rows.Hidden = True
rng2.EntireRow.Hidden = False
.Cut .Range("AJ1")
For Each ar In rng2.Areas
ar.Offset(0, 35).Cut ar(1, 1)
Next
End With
With Application.CommandBars(1).Controls(ProgTitle)
.Controls(1).Enabled = False
.Controls(10).Enabled = True
End With
FiltApplied = True
For i = 1 To 5
Me.Controls("CommandButton" & i).Enabled = (i = 5)
Next
Union(.Columns(2), .Columns(16)).Font.Color = vbBlack
End If
ProcExit:
.ScrollArea = ScrArea
.Protect UserInterfaceOnly:=True
End With
Set ar = Nothing
Set rng = Nothing
Set rng2 = Nothing
If ActiveCell.EntireRow.Hidden Then Call GoToFirstUnhidden
ActiveWindow.ScrollRow = 1
'Beep
Application.ScreenUpdating = True
End Sub

Sub RemoveFilter()
Dim rw As Range, rng As Range, ar As Range
Dim ScrArea As String

Application.ScreenUpdating = False
With Application.CommandBars(1).Controls(ProgTitle)
.Controls(10).Enabled = False
.Controls(1).Enabled = True
End With
With MainWks
.Unprotect
ScrArea = .ScrollArea
.ScrollArea = ""
For Each rw In .UsedRange.EntireRow
If rw.Hidden = True Then
If rng Is Nothing Then Set rng = rw.Resize(1, 33) Else _
Set rng = Union(rng, rw.Resize(1, 33))
End If
Next
If Not rng Is Nothing Then
For Each ar In rng.Areas
ar.Offset(0, 35).Cut ar(1, 1)
Next
End If
.Rows.Hidden = False
Union(.Columns(2), .Columns(16)).Font.Color = SheetBackColor
.ScrollArea = ScrArea
.Protect UserInterfaceOnly:=True
End With
Application.ScreenUpdating = True
FiltApplied = False
Set rng = Nothing
Set rw = Nothing
End Sub

 

[Jim Cone]

Greg,

Try setting your worksheet .DisplayPageBreaks property to False
every time after hiding or showing a row.

Regards,
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware



"Greg Wilson" <[email protected]>
wrote in message...
This is a bit verbose but no debugging is required. Both macros work.

The problem is that each time I run the below ApplyFilter macro and then the
RemoveFilter macro, execution becomes progressively slower. It is only
apparent when there is a lot of data being filtered (which is normally the
case). The problem is much worse using xl2002 versus xl2000. When I monitor
the memory usage of Excel.exe through the Task Manager it becomes
progressively larger. When I close and reopen the workbook it reverts to
normal. Note that I take care to destroy the range variables at the end of
each to no avail. Using API code to clear the clipboard and setting
CutCopyMode to False don’t help either. I don't think using Cut with this
syntax involves the clipboard anyway.

There’s a reason I don’t just hide and unhide rows to accomplish filtering
and unfiltering (or use AutoFilter) but I’ll not go into that here. This is
an important part of a large and project so I’m quite concerned. Hoping
someone has encountered this before and has a solution. Very appreciative of
your assisatance.

Sub ApplyFilter(Filter As String, SearchType As String)
Dim rng As Range, rng2 As Range, ar As Range
Dim rw As Long
Dim i As Integer
Dim ScrArea As String

On Error GoTo ProcExit
Filter = Trim(Filter)
Application.ScreenUpdating = False
With MainWks
ScrArea = .ScrollArea
.ScrollArea = ""
With Intersect(.UsedRange, .Range("D:F"))
Set SearchCell = .Find(Filter, LookAt:=LookAtType, MatchCase:=MchCase)
If Not SearchCell Is Nothing Then
rw = SearchCell.Row
If SearchCell(1, 0) = SearchType Then
Set rng = FormatRegion(SearchCell, SheetBackColor)
Set rng2 = rng.Resize(rng.Rows.Count + 3, 33)
End If
Do
Set SearchCell = .FindNext(SearchCell)
If Not SearchCell Is Nothing Then
If SearchCell(1, 0) = SearchType Then
Set rng = FormatRegion(SearchCell, SheetBackColor)
Set rng = rng.Resize(rng.Rows.Count + 3, 33)
If rng2 Is Nothing Then Set rng2 = rng Else Set rng2 = Union(rng2, rng)
End If
Else
Exit Do
End If
Loop While SearchCell.Row > rw
End If
End With
If rng2 Is Nothing Then
Call FailedSearchMsg(1, Filter, SearchType)
Else
With .Range("A2:AF" & .UsedRange.Rows.Count + 1)
.Rows.Hidden = True
rng2.EntireRow.Hidden = False
.Cut .Range("AJ1")
For Each ar In rng2.Areas
ar.Offset(0, 35).Cut ar(1, 1)
Next
End With
With Application.CommandBars(1).Controls(ProgTitle)
.Controls(1).Enabled = False
.Controls(10).Enabled = True
End With
FiltApplied = True
For i = 1 To 5
Me.Controls("CommandButton" & i).Enabled = (i = 5)
Next
Union(.Columns(2), .Columns(16)).Font.Color = vbBlack
End If
ProcExit:
.ScrollArea = ScrArea
.Protect UserInterfaceOnly:=True
End With
Set ar = Nothing
Set rng = Nothing
Set rng2 = Nothing
If ActiveCell.EntireRow.Hidden Then Call GoToFirstUnhidden
ActiveWindow.ScrollRow = 1
'Beep
Application.ScreenUpdating = True
End Sub

Sub RemoveFilter()
Dim rw As Range, rng As Range, ar As Range
Dim ScrArea As String

Application.ScreenUpdating = False
With Application.CommandBars(1).Controls(ProgTitle)
.Controls(10).Enabled = False
.Controls(1).Enabled = True
End With
With MainWks
.Unprotect
ScrArea = .ScrollArea
.ScrollArea = ""
For Each rw In .UsedRange.EntireRow
If rw.Hidden = True Then
If rng Is Nothing Then Set rng = rw.Resize(1, 33) Else _
Set rng = Union(rng, rw.Resize(1, 33))
End If
Next
If Not rng Is Nothing Then
For Each ar In rng.Areas
ar.Offset(0, 35).Cut ar(1, 1)
Next
End If
.Rows.Hidden = False
Union(.Columns(2), .Columns(16)).Font.Color = SheetBackColor
.ScrollArea = ScrArea
.Protect UserInterfaceOnly:=True
End With
Application.ScreenUpdating = True
FiltApplied = False
Set rng = Nothing
Set rw = Nothing
End Sub

 

[Guest]

Thanks Jim for your time. I tried your suggestion in spite of the fact that
no page breaks show after execution. It was not successful.

At the start, Excel.exe memory usage is 36.4 meg and after about six
executions of the two macros it grows to about 42 meg. Execution time
increases eponentially, starting at slightly over 1 second to approx. 12
seconds after six executions. The problem is an order of magnitude worse
using xl2002 for some reason. An earlier version that inserted cells to move
the contents rather than using Cut was worse.

I've seen a post implicating the Union method for causing slow execution but
only (as memory serves) after approx. 400 noncontiguous ranges are involved.
This is not the case here. I might try tagging the ranges, say with the
letter "x", and using SpecialCells instead of Union. I'm not at all
optimistic though.

The reason I use this complex filter/unfilter method is that achieving this
by simply hiding/unhiding rows results in thousands of rows fitting inside
the visible range due to the row compression. In my case, there are lots of
different formats within the filtered ranges and Excel apparently still
paints the contents of hidden rows. This results in very poor performance
when scrolling. Therefore, I boot the contents outside of the visible range
after hiding the rows. I then put back the contents I want to show. The
problem was very profound and is completely fixed by this approach so I don't
doubt my theory. However, just in case you or someone else has a better
solution to the scroll problem, this would be much better than fixing the
other problem.

By the way, I did manually tag the ranges I want to display with the letter
"x" and used Excel's Autofilter to make sure it wasn't just an artifact of my
own filter. I confirmed that Autofilter had the same problem.

Thanks again Jim.

Greg

 

[Guest]

Hi Greg,

there are lots of different formats within the filtered ranges and Excel apparently
still paints the contents of hidden rows. This results in very poor performance
when scrolling.

Perhaps you could try using the Advanced Filter. It can copy the "hits"
(including their formats) to a different section of the worksheet whilst
leaving the database intact.


Regards,
Vic Eldridge

 

[keepITcool]

Greg,

my guess on why it gets progressively slower
is caused by the union command.

using union is ok if the multiarea has 300 or so
areas. Above that it seems to bog down.

Add a check to verify the area count of the range.
if >300 then "flush" the union either by processing it's areas,
or by "parking it" in a collection.

:
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


Greg Wilson wrote in

 

[Guest]

Thanks Vic for your help.

You probably recall the lab information management program (LIMS) that I
posted several months back which you responded to. This is that project. I
work on it only in my spare time.

The filtered ranges are shaded multi-row ranges that serve as "Lab Order"
forms and each multi-row range is treated as a unit. Filtering involves
either hiding or showing these ranges. Also, there is a great deal of
worksheet event code behind it that I want to remain functional for the
filtered data. So it would require duplication of this code if I were to copy
the "hits" and move them elsewhere. And changes made to these filtered Lab
Orders need to be reflected in the source Lab Orders. This is why I resorted
to the Cut method instead. I cut all data and move it outside of the visible
range and then put back the minority that I want to view.

For the reasons described above, I don't think Advanced Filter can be used.
I do intend to study up on it though. I'm only familiar with AutoFilter. It
looks very useful.

Thanks again Vic.

Greg

 

[Guest]

I hope you're right about the Union command. My code uses union to splice
hundreds of multi-row ranges together, but most of these are also contiguous.
So the actual number of areas involved is small - i.e. one more than the
number of "hits", or typically in the order of ten or so.

Q1 Perhaps Union gets bogged down by the total number of added ranges as
opposed to resultant areas ???

Q2 I didn't understand what you meant by processing the areas. My code does
this:

< If rng2 Is Nothing Then Set rng2 = rng Else Set rng2 = Union(rng2, rng)
'more code
< For Each ar In rng2.Areas
< ar.Offset(0, 35).Cut ar(1, 1)
< Next

Q3 I didn't understand what you meant by "parking it" in a collection. Did
you mean add the ranges to a collection instead of using Union to splice
them. If this is the case then I would need to process each item in the
collection (hundreds) as opposed to each area in the spliced range (approx.
10) created by Union.

Regards,
Greg

 

[keepITcool]

See following demos.
the 1st shows it takes around 40secs for a 2000 area range.
the 2nd uses a collection and takes around 3 seconds for the full
monty.
(each item in the collection holds a 96 area range)

be aware that if you start cutting and deleting
that you should enumerate the collection from END to BEGIN with STEP -1



Sub BogDemo()
Dim i&, s%, t!, r As Range
For s = 1 To 2
t = Timer
For i = 1 To Choose(s, Rows.Count, 4000) Step s
If r Is Nothing Then
Set r = Rows(i)
Else
Set r = Union(r, Rows(i))
End If
Next
MsgBox Timer - t & "Step" & s & " " & "Areas" & r.Areas.Count
Set r = Nothing
Next
End Sub

Sub ColDemo()
Dim i&, t!, r As Range, c As Collection
t = Timer
Set c = New Collection
For i = 1 To Rows.Count Step 2
If r Is Nothing Then
Set r = Rows(i)
Else
Set r = Union(r, Rows(i))
If r.Areas.Count >= 96 Then
c.Add r
Set r = Nothing
End If
End If
Next

MsgBox Timer - t & vbLf & "Collection holds " & _
c.Count & " multiarea ranges of 96 areas"
End Sub


--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


Greg Wilson wrote in

 

[Guest]

Thanks keepITcool. That's very interesting. Unfortunately, I don't think it
is responsible for my problem however. There are only typically about 10
areas involved. I intend to experiment with your suggestion just in case
there is some interaction with the issue you describe and some unknown.

I experimented with not using the Cut method and only hiding/unhiding rows
(i.e. conventional filter/unfilter) and left the Union code the same.
Execution was excellent (< 1 sec) and it did not become progressively slower
with multiple executions. This seems to prove that it is the Cut method that
is the problem. It was also worse when I inserted/deleted cells to move the
contents in an earlier version. As I mentioned, leaving the contents within
the visible range, even if hidden, results in a scrolling problem if there
are enough hidden rows. So this isn't the desired solution.

Best regards,
Greg