algorithm to INVERT a multiarea selection ?

[keepITcool]

Hi..

this one's for the experts/mathematicians amongst us..
(Harlan, you reading this ?


does anyone have some routines to invert a (multiarea) selection?
or ...along the same line of thought ..

to get the the inverse of intersect.. (generally that would give a
"LEFT" bucket and a "RIGHT" bucket.

It MUST be fast.. thus a simple loop will never suffice.
unions above 400 areas get dreadfully slow..

My theory (and bit of practice too

First get the 'outside range' sized from topleft to bottom right cell
of the multiarea.. that's done. (be carefull of unordered areas.)

Then create an array of same dimensions... and mark off the selected
cells. much faster then checking intersect during a 'normal' loop.

But then..? I need an efficient routine to create a a new range object
from that array... Since you want to avoid just dumping every TRUE in
the array in a union and let excel figure it out..

SO probably I need a 'mazing' algorithm but there I'm stuck for the
moment..and I'm pretty sure there must be some nice routines out there!


anyone?..

 

[Tom Ogilvy]

I haven't seen any and this apparently been discussed in detail on compuserv
several years ago. My suggestion, although kludgy, was to use a dummy
worksheet, fill the union with constants, clear the intersection, then use
specialcells with the union to return the inverse.

 

[keepITcool]

I'd thought about that, but find it too kludgy.
(then again.. i'll compromise my principles for speed..
IF nobody comes with a neater approach..

I hate using temp sheets in an existing book
as the sheet counts gets upped... same reason why
i dont really like 'on the fly' workbooks


Anybody else?... still open for suggestions




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


Tom Ogilvy wrote :

 

[Norman Jones]

Hi KeepItCool,

You can see the conversation to which Tom alludes at :

http://tinyurl.com/5yyl4

Stealing acombination of these ideas, I use the following function which, in
my timings, is significantly faster than loop approaches that i tried.

Function RangeNot(RngA As Range, Optional RngB As Range, _
Optional WS As Worksheet)
' Using Dave Peterson interpretation of Tom Ogilvy's
' scratch sheet
' Adapted to replace the scratchsheet using Dana DeLouis's
' Validation idea
'Adapted as a function

Dim wks As Worksheet

If WS Is Nothing Then Set WS = Activesheet

If RngB Is Nothing Then Set RngB = Activesheet.UsedRange

With Union(RngA, RngB).Validation
.Delete
.Add 0, 1
End With

Intersect(RngA, RngB).Validation.Delete

Set RangeNot = Union(RngA, RngB).SpecialCells(xlCellTypeAllValidation)

End Function

 

[Norman Jones]

Hi KeepItCool,

I managed to cut/paste/combine and screw that up!

The function should read more along the lines of:

Function RngNot(RngA As Range, _
Optional RngB As Range, _
Optional WS As Worksheet) As Range
'------------------------------
' Using Dave Peterson interpretation of Tom Ogilvy's
' scratch sheet
' Adapted to replace the scratchsheet using Dana DeLouis's
' Validation idea
'Adapted as a function
'-----------------------------
If RngB Is Nothing Then Set RngB = ActiveSheet.UsedRange
If WS Is Nothing Then Set WS = ActiveSheet

With Union(RngA, RngB).Validation
.Delete
.Add 0, 1
End With

Intersect(RngA, RngB).Validation.Delete

Set RngNot = Union(RngA, RngB). _
SpecialCells(xlCellTypeAllValidation)
End Function

 

[keepITcool]

Norman.. this looks very usefull!

there's a few things in the code that could be tightened up.

WS argument can be removed.

if we use this..

if rngB is nothing then set rngB=rngA.Parent.usedrange

we don't need WS..
(rngB and RngA must be on the same sheet for a union to work anyway)

also I want to build in some checks:
in order not to destroy existing Validation...
if there is no intersect
if rngA iss within rngB (or vice versa)


I'll post back tomorrow !!



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


Norman Jones wrote :

 

[Norman Jones]

Hi KeepItCool,

there's a few things in the code that could be tightened up

The function was derived from something else not immediately pertinent here
.. Hence the initial post and lack of optimisation.

 

[Tom Ogilvy]

I'd thought about that, but find it too kludgy.

Norman.. this looks very usefull!

wow, you hooked onto that like a hungry baby to the nipple. <LOL>

 

[Norman Jones]

Hi KeepITcool,

I have amended this function taking your comments into account. More
specifically,

WS argument can be removed.

Agreed - I actually intended the WS variable to refer to a variable sheet
but manged to fall between two stools.

if rngB is nothing then set rngB=rngA.Parent.usedrange

Yes - Happily incorporated.

(rngB and RngA must be on the same sheet for a union to work anyway)

Yes - see WS point above.

also I want to build in some checks

in order not to destroy existing Validation...

I agree that this is necessary. I have amended the function to build an
array to store all possible validation variables. Once the function has
determined the RngNot range, the validation data is restored to any
validation cells. I hope that I have caught all possible variables.

if there is no intersect

An On Error Resume ... Goto added to catch this.

if rngA iss within rngB (or vice versa)

I looked at this and felt that no special action was required, Since,
however, you have specifically raised the point, you may see more here than
I did after my , admittedly, somemewhat cursory, consideration.

I think that there is (at leat) one futher point to consider: The 8192
non-contiguous cells limitation which, IIR, applies to pre-xl2002 . I
suppose that the logical step would be to adopt an
iI Intersect(RngA, RngB).Areas.Count > 8191 Then
Break rnage into acceptable chunks & loop
End If
appoach.

I wanted to think about this however, not least because, in my testing, the
limit appeared to come into effect close to but definately *before* the
8192. Given other calls on my time, i was unable to rigorously test how far
(if at all) this phenomenon was
due to subtleties of my test parameters or simply error/oversight on my
part.

In any event, this is my revised code:

Function RngNot(RngA As Range, Optional RngB As Range) As Range
'---------------------------------------------
' Using Dave Peterson's interpretation of Tom Ogilvy's
' scratch sheet idea
' Adapted to replace the scratchsheet using Dana DeLouis's
' Validation idea
' Adapted as a function
' Amended to satisfy the need (pointed out by KeepITcool)
' to restore original validation - Validation values passed
' to and from an array
' Amended to add Non-Intersection error handling (KeepITcool)
'---------------------------------------------
Dim Rng As Range, cell As Range, i As Long

If RngB Is Nothing Then Set RngB = RngA.Parent.UsedRange

On Error Resume Next
Set Rng = Union(RngA, RngB).SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0

If Not Rng Is Nothing Then
ReDim arr(1 To Rng.Cells.Count, 1 To 14)
i = 0
For Each cell In Rng
i = i + 1
With cell.Validation
arr(i, 1) = cell.Address
arr(i, 2) = .Type
arr(i, 3) = .AlertStyle
arr(i, 4) = .Operator
arr(i, 5) = .Formula1
arr(i, 6) = .Formula2
arr(i, 7) = .ErrorMessage
arr(i, 8) = .ErrorTitle
arr(i, 9) = .IgnoreBlank
arr(i, 10) = .InputMessage
arr(i, 11) = .InputTitle
arr(i, 12) = .ShowError
arr(1, 13) = .ShowInput
arr(1, 14) = .InCellDropdown
End With
Next cell

Rng.Validation.Delete
End If

Union(RngA, RngB).Validation.Add 0, 1

On Error Resume Next
Intersect(RngA, RngB).Validation.Delete
On Error GoTo 0
Set RngNot = Union(RngA, RngB). _
SpecialCells(xlCellTypeAllValidation)
RngNot.Validation.Delete
If Not Rng Is Nothing Then
For i = LBound(arr) To UBound(arr)
With Range(arr(i, 1)).Validation
.Add Type:=arr(i, 2), AlertStyle:=arr(i, 3), _
Operator:=arr(i, 4), Formula1:=arr(i, 5), _
Formula2:=arr(i, 6)
.ErrorMessage = arr(i, 7)
.ErrorTitle = arr(i, 8)
.IgnoreBlank = arr(i, 9)
.InputMessage = arr(i, 10)
.InputTitle = arr(i, 11)
.ShowError = arr(i, 12)
.ShowInput = arr(1, 13)
.InCellDropdown = arr(1, 14)
End With
Next i
End If
End Function

 

[Norman Jones]

Hi KeepITcool

Typo warning!

In the last two lines of the array load:

arr(1, 13) = .ShowInput
arr(1, 14) = .InCellDropdown

and. analogously, in the last two lines of the array unload

.ShowInput = arr(1, 13)
.InCellDropdown = arr(1, 14)

replace arr(1, with arr(i,


( The legacy of an over-confident search & replace!)

 

[keepITcool]

yep.. have you seen how FAST this is. Perfect.

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


Tom Ogilvy wrote :

 

[keepITcool]

Norman..

took a while... sorry.


made my own version of things.. heavily based on your original
following alterations:
added the use of formatconditions
finding existing validation via recursive SC(samevalid)
extra option to inverse on the 'outer boundary square' of input rangeA

not utterly tested.. but time is lacking
i'll store this for now... more things to do.

thanks for all the input,

Jurgen Volkerink
aka
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam



Function Inverse(rngA As Range, Optional bUsedRange As Boolean, _
Optional rngB As Range) As Range
' Freely adapted by keepitcool from :
' Adapted from Norman Jones 2004 Jul 22 'Inverse Selection
' Adapted from thread 2003 Oct 12 'Don't Intersect
' thread contributors Tom Ogilvy, Dave Peterson, Dana DeLouis

Dim lCnt&, itm, colDV As Collection
Dim iEvt%, iScr%

If rngB Is Nothing Then
If bUsedRange Then
Set rngB = rngA.Parent.UsedRange
Else
Set rngB = Square(rngA)
End If
Else
On Error Resume Next
lCnt= Intersect(rngA, rngB).Count
On Error GoTo 0
If lCnt = 0 Then Exit Function Else lCnt = 0
End If

With Application
iEvt = .EnableEvents: .EnableEvents = False
iScr = .ScreenUpdating: .ScreenUpdating = False
End With

Set colDV = New Collection

With Union(rngA, rngB)

useFC:
On Error Resume Next
lCnt = .SpecialCells(xlCellTypeAllFormatConditions).Count
On Error GoTo 0
If lCnt > 0 Then GoTo useDV

.FormatConditions.Add 1, 3, 0
Intersect(rngA, rngB).FormatConditions.Delete
Set Inverse = .SpecialCells(xlCellTypeAllFormatConditions)
Inverse.FormatConditions.Delete
GoTo theExit

useDV:
Do
On Error Resume Next
If IsError(.SpecialCells(xlCellTypeAllValidation)) Then Exit Do
On Error GoTo 0
With Intersect(.Cells, _
.Cells.SpecialCells(xlCellTypeAllValidation) _
.Cells(1).SpecialCells(xlCellTypeSameValidation))

With .Validation
colDV.Add Array(.Parent.Cells, _
.Type, .AlertStyle, .Operator, .Formula1, .Formula2, _
.IgnoreBlank, .InCellDropdown, _
.ShowError, .ErrorTitle, .ErrorMessage, _
.ShowInput, .InputTitle, .InputMessage)
.Delete
End With
End With
Loop

.Validation.Add 0, 1
Intersect(rngA, rngB).Validation.Delete
Set Inverse = .SpecialCells(xlCellTypeAllValidation)
Inverse.Validation.Delete
End With

theExit:
If colDV.Count > 0 Then
For Each itm In colDV
With itm(0).Validation
.Add itm(1), itm(2), itm(3), itm(4), itm(5)
.IgnoreBlank = itm(6)
.InCellDropdown = itm(7)
.ShowError = itm(8)
.ErrorTitle = itm(9)
.ErrorMessage = itm(10)
.ShowInput = itm(11)
.InputTitle = itm(12)
.InputMessage = itm(13)
End With
Next
End If

With Application
.EnableEvents = iEvt
.ScreenUpdating = iScr
Exit Function
End With

End Function

Function Square(rng As Range) As Range
'Finds the 'square outer range' of a (multiarea) range
Dim c1&, cn&, r1&, rn&, x1&, xn&, a As Range

r1 = &H10001: c1 = &H101
For Each a In rng.Areas
x1 = a.Row
xn = x1 + a.Rows.Count
If x1 < r1 Then r1 = x1
If xn > rn Then rn = xn
x1 = a.Column
xn = x1 + a.Columns.Count
If x1 < c1 Then c1 = x1
If xn > cn Then cn = xn
Next
Set Square = rng.Worksheet.Cells(r1, c1).Resize(rn - r1, cn - c1)

End Function

 

[Peter T]

Hi Norman

I have been working with this method to subtract ranges
for some while. I had always attributed this to Dana
DeLouis, but reading the links in this thread it appears
to be a logical development of an old idea of Tom Ogilvy's
(I don't mean to detract anything from Dana's clever idea).

In XL97, but not XL2k, I find problems (crash) restoring
validation from a variant array, and would need to amend
to something like this:

Function RngNot(RngA As Range, Optional RngB As Range) _
As Range
Dim Rng As Range, cell As Range, i As Long
'code

'store validation
Dim cnt As Long
cnt = Rng.Cells.Count
ReDim Narr(1 To cnt, 1 To 3) As Long
ReDim Barr(1 To cnt, 1 To 4) As Boolean
ReDim Sarr(1 To cnt, 1 To 7) As String
i = 0
For Each cell In Rng
i = i + 1
With cell.Validation
Sarr(i, 1) = cell.Address
Narr(i, 1) = .Type
Narr(i, 2) = .AlertStyle
Narr(i, 3) = .Operator
Sarr(i, 2) = .Formula1
Sarr(i, 3) = .Formula2
Sarr(i, 4) = .ErrorMessage
Sarr(i, 5) = .ErrorTitle
Barr(i, 1) = .IgnoreBlank
Sarr(i, 6) = .InputMessage
Sarr(i, 7) = .InputTitle
Barr(i, 2) = .ShowError
Barr(i, 3) = .ShowInput
Barr(i, 4) = .InCellDropdown
End With
Next cell

'code

'replace validation
For i = 1 To cnt
With Range(Sarr(i, 1)).Validation
.Delete 'new line
.Add Type:=Narr(i, 1), AlertStyle:=Abs(Narr(i, 2)), _
Operator:=Narr(i, 3), Formula1:=Sarr(i, 2), _
Formula2:=Sarr(i, 3)
.ErrorMessage = Sarr(i, 4)
.ErrorTitle = Sarr(i, 5)
.IgnoreBlank = Barr(i, 1)
.InputMessage = Sarr(i, 6)
.InputTitle = Sarr(i, 7)
.ShowError = Barr(i, 2)
.ShowInput = Barr(i, 3)
.InCellDropdown = Barr(i, 4)
End With
Next I
'code
End Sub

Couple of comments:

Intermittently, if .AlertStyle is xlValidAlertStop ( a
long 1) it can get returned as -1. I don't know why but
hence AlertStyle:=Abs(Narr(i, 2)), I havn't noticed a
problem with the other longs.

Replacing validation, code can fail if the first line is
not
..Delete
even if there is no existing validation in the cell. Again
I don't know why.

I have also tried similar with collection and a class -
given up! I remain nervous of the possibility of not fully
restoring any validation, even if it's the user getting
bored and trying to abort. So currently I adapt the entire
method so as not to change validation on the user's sheet.
There are at least two reasonable, albeit slower,
workarounds.

I think that there is (at least) one futher point to
consider: The 8192 non-contiguous cells limitation which,
IIR, applies to pre-xl2002. I suppose that the logical
step would be to adopt an
If Intersect(RngA, RngB).Areas.Count > 8191 Then
Break rnage into acceptable chunks & loop
End If
appoach.

I wanted to think about this however, not least because,
in my testing, the limit appeared to come into effect
close to but definately *before* the 8192.

In quite a bit of testing of the 8192 areas / special
cells limit, I have never failed to select less than the
full contents in 8192 areas. I suspect the problem here
may be related to use of Intersect with close to this
number of areas (could be my ageing system resources),
rather than specifically the 8192 limit with specialcells.

Even some way below this level various problems can arise,
including the possibility of the user getting bored and
trying to abort (Set Intersect x000 areas takes a while).
For me the 8192 limit is somewhat academic, I would prefer
to break up into say a max 2000 areas in each range. Also,
I suspect 3 x 2000 and union would be faster than 1 x 6000.

I don't have a good method for this - ie split
into "pairs" of smaller chunks. For KeepItCool it might
not be too difficult, he only wants to get the "Inverse"
range. One or both my ranges could include very many
areas, first and last areas might not include top left and
bottom right cells respectively in each range. It has
stumped me - I don't suppose you would have any thoughts
on this!

Regards,
Peter

 

[Norman Jones]

Hi Jurgen,

I have, as yet, only been able fleetingly to scan read your code as She who
must be obeyed commands my presence.

I will respond in more detail later but two quick, off-the-cuff comments::

(1) I like your idea of conditionally employing CF instead of DV if CF
is not in use. Immediately I am tempted to consider alternatives to either
option. One or two likely candidates spring to mind for later consideration
....

(2) The follwing lines from your code concern me:

With Union(rngA, rngB)
[snip]
.FormatConditions.Add 1, 3, 0
Intersect(rngA, rngB).FormatConditions.Delete
Set Inverse = .SpecialCells(xlCellTypeAllFormatConditions)
Inverse.FormatConditions.Delete
GoTo theExit

Where no (optional) rRngB is passed to the Inverse function, RngB will, via
your Square function. be set to Range A. In consequence, Union(RngA,RngB)
and Intersect(RngA, RngB) will be coincident. In this situation you are
applying (and immediateley removing) conditional formatting from the
coincident range and, consequently, your Inverse range never gets set and is
returned as Nothing!

But then again, my scan reading was never wonderful!


By the way, I like the collection idea too!

 

[Norman Jones]

Hi Peter,

Your post requires more time than is immediately available to me, but, for
the moment, the briefest anf most telegrammatic of responses:

I have been working with this method to subtract ranges
for some while. I had always attributed this to Dana
DeLouis, but reading the links in this thread it appears
to be a logical development of an old idea of Tom Ogilvy's
(I don't mean to detract anything from Dana's clever idea).

Dana's implentation is wonderful but the Eureka accolade must be for the
simplicity and elegance of Tom Ogilvy's intrinsic idea!

In XL97, but not XL2k, I find problems (crash) restoring
validation from a variant array, and would need to amend
to something like this:

I was not aware of this version problem. At first blush, your suggestion
looks very viable. I will try on xl97 as soon as I can locate an operational
version.

Intermittently, if .AlertStyle is xlValidAlertStop ( a
long 1) it can get returned as -1. I don't know why but
hence AlertStyle:=Abs(Narr(i, 2)), I havn't noticed a
problem with the other longs.

Was not aware of this, thanks for the information!

In quite a bit of testing of the 8192 areas / special
cells limit, I have never failed to select less than the
full contents in 8192 areas. I suspect the problem here
may be related to use of Intersect with close to this
number of areas (could be my ageing system resources),
rather than specifically the 8192 limit with specialcells.

This has to be for later!!


Thank you for your detailed post and apologies for not, immediately,
devoting the response time that it warrants.

 

[Norman Jones]

Dana's implentation is wonderful but the Eureka accolade must be for the

simplicity and elegance of Tom Ogilvy's intrinsic idea!

implentation ?!!!

Should be implementation - I really was in a rush!


___
Regards,
Norman

 

[Norman Jones]

Hi KeepITcool,

Where no (optional) rRngB is passed to the Inverse function, RngB will,

via ...

should have read :

Where RngA is a single area and no (optional) rRngB is passed to the Inverse
function, RngB will, via ...

Apologies for inavertently misleading you.

In light testing, with the sole exception of the single-area RngA / no
explicit RngB scenario, your function version worked excellently and
returned the anticipated range object.

For my purposes, I overcame this problem by changing the opening function
clauses from:

If rngB Is Nothing Then
If bUsedRange Then
Set rngB = rngA.Parent.UsedRange
Else
Set rngB = Square(rngA)
End If
Else

to:

If rngB Is Nothing Then
If bUsedRange Then
Set rngB = rngA.Parent.UsedRange
Else
If rngA.Areas.Count > 1 Then
Set rngB = Square(rngA)
Else
Set rngB = rngA.Parent.UsedRange
End If
End If
Else

 

[keepITcool]

Problem with testing re 8192..

if it's more than 8192 areas then SpecialCells will return 1 solid
range. no error. So you cant test for >8191.

I've done exhaustive testing on this... it's either 8192 or 1.
(regardless of the size/shape of the individual areas.)

Bug is still there in Excel 2003.

although M$ phrases it somewhat differently...

The Excel VBA function ".SpecialCells(xlCellTypeBlanks)" does not work
as expected
<http://support.microsoft.com/default.aspx?scid=kb;en-us;832293>
snippet.. just for laughs
However, when you use a VBA macro to make the same or a similar
selection, no error message is raised and no error code is generated
that can be captured through an error handler.
======================================
STATUS:This behavior is by design.
======================================


If you want to test yourself..

Sub SpecialCellsCantHandleMoreThan8192AreasBugDemo()
Dim r&, c&, n&, rs As Range
Dim v(1 To 2 ^ 16, 1 To 1)
'Fill cells alternating
Cells.Clear
n = ActiveSheet.UsedRange.Count
For r = LBound(v, 1) To UBound(v, 1)
For c = LBound(v, 2) To UBound(v, 2)
If (r + c) Mod 2 = 0 Then v(r, c) = 1
Next
Next
Cells(1, 1).Resize(UBound(v, 1), UBound(v, 2)) = v
'Now let's use SpecialCells to find the blanks
For r = 8192 To 8193

With Cells(1, 1).Resize(2 * r, 1)
With .SpecialCells(xlBlanks)
.Select
If .Areas.Count > 1 Then
MsgBox "8192 areas found.. 1 more?"
Else
MsgBox "Oops.. SpecialCells cant handle more than 8192 areas"
& _
vbNewLine & "it will NOT throw an error, but return 1
large area instead" & _
vbNewLine & Application.CountBlank(.Cells) & " blank
cells s/b selected", vbCritical, "BugDemo"
End If
End With
End With
Next
End Sub




You MUST test for 1. Cuz that's the danger point.

Re problems with array.. wouldn't explicit type conversion
in the restore phase be enough?




I'll read all the comments tomorrow.

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


Peter T wrote :

Hi Norman

I have been working with this method to subtract ranges
for some while. I had always attributed this to Dana
DeLouis, but reading the links in this thread it appears
to be a logical development of an old idea of Tom Ogilvy's
(I don't mean to detract anything from Dana's clever idea).

[snap]

 

[Norman Jones]

Hi Peter,

In quite a bit of testing of the 8192 areas / special
cells limit, I have never failed to select less than the
full contents in 8192 areas. I suspect the problem here
may be related to use of Intersect with close to this
number of areas (could be my ageing system resources),
rather than specifically the 8192 limit with specialcells.

Here is a simple sub which (for me!) returns 1 and 8192 where, in each case,
I would anticipate 8192. When I looked at this last week, I appeared to get
erratic results as the number of non-contiguous areas appoached 8192 and as
the nature/complexity of the parent union ranges increased.

Sub Tester()
Range("A1:B1").Value = CVErr(xlErrNA)
Range("A1:C1").Copy Range("d11")
Range("A2:O2").Value = "A"
Range("A12").AutoFill Destination:=Range("A1:O3277"), _
Type:=xlFillDefault
Range("F3277:O3277").Clear
ActiveSheet.UsedRange.Columns.AutoFit

MsgBox ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, _
xlErrors).Areas.Count
Range("E3277").Clear
MsgBox ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, _
xlErrors).Areas.Count
End Sub

I agree, however, that for present purposes at least, this is academic as:
(1) there is *a* limit (be it at 8192 or, sometimes, slightly less)
(2) processing time increases disproportionately above (say) 4500 areas

It clearly is both necessary and expedient to segment the ranges. The
methodology for this is something that I am lookong at now.

 

[keepITcool]

Norman..

How's this for methodology?
Presuming a selection cannot have more areas than 50% of cells...
This will return a collection of ranges..
Probably should be classed .. but goes to show the idea.

Done some basic testing but even at a:z60000 with 40% random non
blanks.. returned 48 multiarea ranges(avg 7500 areas/range)in the
collection. 90secs.. (1200k cells..372k areas.. but NO errors !

so far so good



Function SegmentedCells(rngA As Range, scType As XlCellType, _
Optional scValue As XlSpecialCellsValue) As Collection

Const m = 8192
Dim r&, l&, s&, rngT As Range, colRaw As Collection

Set colRaw = New Collection
Set SegmentedCells = New Collection

With rngA
If .Areas.Count > 1 Then
Err.Raise vbObjectError + 1, , "No MultiArea as input."
Exit Function
End If
s = (m * 2 \ .Columns.Count)
l = s
If scValue = 0 Then
For r = 1 To .Rows.Count Step s
If r + s > .Rows.Count Then l = .Rows.Count - r + 1
colRaw.Add .Resize(l).Offset(r - 1).SpecialCells(scType)
Next
Else
For r = 1 To .Rows.Count Step s
If r + s > .Rows.Count Then l = .Rows.Count - r + 1
colRaw.Add .Resize(l).Offset(r - 1).SpecialCells(scType, _
scValue)
Next
End If
End With


Set rngT = colRaw(1)
For r = 2 To colRaw.Count
If rngT.Areas.Count + colRaw(r).Areas.Count > 8192 Then
SegmentedCells.Add rngT
Set rngT = colRaw(r)
Else
Set rngT = Union(rngT, colRaw(r))
End If
Next
SegmentedCells.Add rngT

End Function


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


Norman Jones wrote :