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?..
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Tom Ogilvy
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.
--
Regards,
Tom Ogilvy
"keepITcool" <xrrcv...@puryyb.ay> wrote in message
news:xn0dl40kz...@msnews.microsoft.com...
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
You can see the conversation to which Tom alludes at :
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
---
Regards,
Norman
"keepITcool" <xrrcv...@puryyb.ay> wrote in message
news:xn0dl40kz...@msnews.microsoft.com...
>
Norman Jones
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
---
Regards,
Norman
"Norman Jones" <norma...@whereforartthou.com> wrote in message
news:%232GiuHL...@TK2MSFTNGP12.phx.gbl...
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.
---
Regards,
Norman
"keepITcool" <xrrcv...@puryyb.ay> wrote in message
news:xn0dl45jf...@msnews.microsoft.com...
Tom Ogilvy
> Norman.. this looks very usefull!
wow, you hooked onto that like a hungry baby to the nipple. <LOL>
--
Regards,
Tom Ogilvy
Norman Jones
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
Norman Jones
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!)
---
Regards,
Norman
keepITcool
yep.. have you seen how FAST this is. Perfect.
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Tom Ogilvy wrote :
keepITcool
took a while... sorry.
>>> 8192 area bug still unresolved <<<
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
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
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!
---
Regards,
Norman
Norman Jones
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.
---
Regards,
Norman
Norman Jones
> simplicity and elegance of Tom Ogilvy's intrinsic idea!
implentation ?!!!
Should be implementation - I really was in a rush!
___
Regards,
Norman
Norman Jones
> 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
---
Regards,
Norman
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
> 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("d1:o1")
Range("A2:O2").Value = "A"
Range("A1:o2").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.
---
Regards,
Norman
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 :
> I agree, however, that for present purposes at least, this is
> academic as: (1) there is a limit (be it at 8192 or, sometimes,
Norman Jones
Given your time zone, this must be important to you.
> How's this for methodology?
Your function approach looks good.
> so far so good :)
As the blind man said, stepping off the cliff!
I've been thinking of a different approach which is either very sensible or
utter lunacy.
I am loathe to say more for obvious reasons!
By the way, the Inverse function should error check that RngA <>
Usedrange - Obvious, but I failed to allow for it.
---
Regards,
Norman
Peter T
Hope you don't mind my squeezing into your thread.
Really like the CF alternative, gives extra possibilities.
A couple of things with the DV collection if "Goto useDV".
Similar as I mentioned to Norman, in xl97 would need to
change:
With itm(0).Validation
.Add itm(1), itm(2), itm(3), itm(4), itm(5)
to
.Add itm(1), Abs(itm(2)), itm(3), itm(4), itm(5)
The DV Collection correctly replaces, but when doing this:
ActiveCell.SpecialCells(xlCellTypeAllValidation).Select
I get a perfect jigsaw of areas, rather than the single
area of DV I had originally applied over everything. Using
the array method, when done I end up with the original
single area of DV.
Regards,
Peter
>
>
>Function Inverse(rngA As Range, Optional bUsedRange As
Boolean, _
>'code
>
> 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
>
>'code
>
>End Function
>
Peter T
Thanks for your replies.
>Here is a simple sub which (for me!) returns 1 and 8192
>where, in each case, I would anticipate 8192.
Yes I see what you mean, don't know how I missed that. In
the first run max areas is 8191. Similar results manually
with F5 special.
>(2) processing time increases disproportionately above
>(say) 4500 areas
Executing the single line of code to get the 8191/2
specialcells took 50 sec in my system. Valves getting very
hot, about time I upgraded to transistors!
>It clearly is both necessary and expedient to segment the
>ranges. The methodology for this is something that I am
>looking at now
I'm looking forward to your ideas. A toughy - areas at the
boundaries of "pairs" of segments could overlap into
neighbours, might not fill into nice "outer" rectangles.
I had played around with a function very similar to
KeepITcool's "Square" function, although I was trying to
do something with less looping. FWIW here's the seed of
another idea I played with to reduce looping.
Function rRect2(rng As Range) As Range
Set rRect2 = Intersect(rng.EntireColumn, rng.EntireRow)
End Function
Sub Test1()
Dim rMulti As Range, rRect As Range, a As Range
Dim i As Long
Cells.Clear
'first range has no totally empty rows/cols
Set rMulti = _
Range("C1:C2,D3:D4,E5:E6,B7:B8")
'Set rMulti = _
Range("C1:C2,E4:E5,G7:G8,B10:B11")
For Each a In rMulti.Areas
i = i + 1
a.Value = i
Next
rRect2(rMulti).Select
MsgBox Selection.Address
End Sub
Regards,
Peter
PS I'm a bit behind, not yet looked at KeepItcool's
Peter T
>must be for the simplicity and elegance of Tom Ogilvy's
>intrinsic idea!
Indeed, and nicely expressed.
I can't help wonder if Tom might have allowed a wry
chuckle to himself at the notion he might be surprised by
the speed of this approach <vbg> (earlier this thread).
>implentation ?!!!
>Should be implementation - I really was in a rush!
I really didn't notice until you corrected. Worrying - I
use the same eyes for reading my own code!
Peter
keepITcool
on the contrary thanks for budding in :)
i'm collecting answers here from multi branches in this thread...
this is off the cuff.. no testing.
do you mean that
a: the selection is incorrect
or
b: that the 'areas' are only 'jumbled'
this seems due to fact that any union or intersect is build from the
ACTIVEcell forwards.. and wraps around at the end.. first selected
cell..alas afaik no easy way to recreate/reorder a 'hashed' multiarea :(
(hence the threads' title?)
'============================
re other thread Square():
'============================
Peter.. be careful there..
i'had already done some speedtesting.
looping may not look cool.
and all the variables may not look cool either..
you CANNOT depend on the SEQUENCE of multiareas.
using entirerow/column definitely slows it down.
> Function rRect2(rng As Range) As Range
> Set rRect2 = Intersect(rng.EntireColumn, rng.EntireRow)
> End Function
'================================
Re How's this for methodology..
'================================
Significant speed improvement if following change is made to
prevent (slow) reunions when either multia is 4096.
(disproportionate etc :)
change THIS
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
to THIS:
Set rngT = colRaw(1)
For r = 2 To colRaw.Count
If rngT.Areas.Count + colRaw(r).Areas.Count > m \ 2 Then
SegmentedCells.Add rngT
Set rngT = colRaw(r)
Else
Set rngT = Union(rngT, colRaw(r))
End If
Next
SegmentedCells.Add rngT
i've got the feeling we'll be back :)
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Peter T wrote :
Peter T
>do you mean that
>a: the selection is incorrect
>or
>b: that the 'areas' are only 'jumbled'
I meant b: DV is correctly restored using the Collection,
but in a bunch of jumbled areas, rather than the single
area I had applied over everything before testing. I had
thrown two multiple, partially intersecting ranges at
your "Inverse" function. With same test ranges and
Norman's array of DV, I end up with the original single
area of DV. Somehow I forgot to add explanation in my last
post!
Typically a user is unlikely to start with many areas of
DV on his sheet. But could have (say) a couple of columns
of several thousand rows of identical DV - but that's only
one or two areas. Depending on what one's doing, and I
appreciate this might not be applicable in your scenario,
one could end up correctly restoring DV but as several
"jumbled" areas. Not sure what if any implications this
might have, but I would prefer to avoid.
'============================
re other thread Square():
'============================
>Peter.. be careful there..
>you CANNOT depend on the SEQUENCE of multiareas.
>using entirerow/column definitely slows it down.
>> Function rRect2(rng As Range) As Range
>> Set rRect2 = Intersect(rng.EntireColumn, rng.EntireRow)
>> End Function
I had played with this as a precursor to finding
the "outer" coordinates of a multiple range. Idea was
looping this would be faster than looping all the areas.
But I didn't get very far.
'================================
Re How's this for methodology..
'================================
>Significant speed improvement if following change is made
>to prevent (slow) reunions when either multia is 4096.
4096, or even perhaps 2048?
At this point I need to say that my vba skills are several
pegs down the ladder from those of yours and Norman's -
I have not yet worked out how to use or implement
your "SegmentedCells" function in context. It looks clever
and useful - I'll get there in the end!
A quickie -
>Presuming a selection cannot have more areas than 50%
>of cells...
I think that depends how the range is created.
Theoretically, after adding / subtracting, I could end up
with:
MsgBox Range("a1,b2,a2,b1").Areas.Count
'or "C1,B2:C2,A3:B3,B4:C4,C5" '5 areas 8 cells
>i've got the feeling we'll be back :)
Quicker than you thought!
Regards,
Peter
>.
>
Norman Jones
> I think that depends how the range is created.
> Theoretically, after adding / subtracting, I could end up
> with:
>
> MsgBox Range("a1,b2,a2,b1").Areas.Count
> 'or "C1,B2:C2,A3:B3,B4:C4,C5" '5 areas 8 cells
>
I think that this is misleading. I think the central issue is the number of
non-contiguous areas.
Also, consider:
? range("A1,A2,A3,A4").Areas.Count
4
---
regards,
Norman
"Peter T" <pet...@discussions.microsoft.com> wrote in message
news:460b01c47332$4d4345f0$a501...@phx.gbl...
Myrna Larson
commas, rather than A1:A4), then it has 4 areas.
The following line executed in the immediate window, prints 1:
? union(Range("A1"),Range("A2"),Range("A3"),Range("A4")).Areas.Count
1
If I change "A4" to "D4", it prints 2.
Norman Jones
Piicking up the verbal skirmish from the third party thread,
You alluded to probleme distinguishing between a a MA 8182+ rogue aingle
area and a legitimate single area. I responded with lazy pseudo code:
I suggested (in lazy pseudo code)
If AreasCount = 1 and If CountBlanks(Area) Then = Bug Area
You responded:
ouch.. that wont do.. think about following:
what if my rngA was specialcells(numbers)
or just a manual selection.. nah.. wont do.. :(
Ok, enlighten me as to where the following falls down - I just code-jotted
the principle, which is that a legitimate single area will have no blank
cells, whilst an 8192 bug area will have many:
Sub Detect8192Areas()
Dim Rng As Range
Dim WS As Worksheet
Set WS = Sheets.Add
WS.Range("A1") = 100 ' CVErr(xlErrNA)
Set Rng = WS.Range("A1").Resize(2)
Range("A1:A2").AutoFill Destination:=Range("A1:a16500"), _
Type:=xlFillDefault
With WS.Columns(1)
With .SpecialCells(xlConstants, xlNumbers)
Debug.Print .Areas.Count & vbTab & _
Application.CountBlank(Range(.Address))
If .Areas.Count = 1 And _
Application.CountBlank(Range(.Address)) Then
MsgBox " This range has more " & _
"than 8192 non-contiguous areas!"
End If
End With
End With
End Sub
---
Regards,
Norman
"keepITcool" <xrrcv...@puryyb.ay> wrote in message
news:xn0dl7u5...@msnews.microsoft.com...
Norman Jones
> area and a legitimate single area. I responded with lazy pseudo code:
Let me try to re-type that phrase with a modicum of comprehensibility:
You alluded to problems in distinguishing between a rogue 8192+ MS
SpecialCells area and a legitimate single-area range. I responded with lazy
pseudo code
---
Regards,
Norman
"Norman Jones" <norma...@whereforartthou.com> wrote in message
news:eicYaq4c...@TK2MSFTNGP12.phx.gbl...
> Hi KeepItCool,
>
> Piicking up the verbal skirmish from the third party thread ...
keepITcool
Norman
of course your code works IF the preamble is that we're trying to
'invert' a range where the 'selection criteria' is clear
The problem is INSIDE the 'invert' function we're just presented with a
multiarea range....
The function doesn't know HOW that multiarea was built. and IF it has
any identifying traits to test on.
THUS your checker method must reside in the caller procedure.
or am i missing something :)
keepITcool
I think i'm on the way with..
.. needs some testing but it makes sense ..
.. until it bugs out elsewhere..
'pseudo..
If rngResult.areas.count>1 then
Set Inverse=rngResult
else
on error resume next
lCnt=intersect(rngA,rngResult).count
on error goto 0
if lcnt=0 then
Set InVerse = rngResult
else
Inverse=cverr(xlErrRef)
endif
endif
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Norman Jones wrote :
> Hi KeepItCool,
Norman Jones
No disagreement after all! I misunderstood the context of your remark:
>> offTopic to Norman.
still working on the 'final' inverse/notrange/complement..
my solution re 8192 bug
iso actually handling it inside the function i decided to
just go into 'error' mode when the inversed area count = 1
although THAT may be a valid situation.. :(
so now i got to work on that..arghhh
<g> <<
---
Regards,
Norman
"keepITcool" <xrrcv...@puryyb.ay> wrote in message
news:xn0dl9dae...@msnews.microsoft.com...
Thomas Ramel
keepITcool schrieb am 23.07.2004
> 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..
I just found this thread here.
Maybe the following functions could do the 'trick'?
Sub Test()
InversRange(Selection).Select
End Sub
Public Function InversRange(Bereich As Range) As Range
Dim lngI As Long
Dim rngBereich As Range
On Error GoTo err_Select
Set rngBereich = Invers_Area(Bereich.Areas(1))
For lngI = 2 To Bereich.Areas.Count
Set rngBereich = Intersect(rngBereich, _
Invers_Area(Bereich.Areas(lngI)))
Next
Set InversRange = rngBereich
Exit Function
err_Select:
'in dieser Anwendung kann man hier ruhig nothing setzen,
'Activecell war nur benutzt, um eine Fehlermeldung zu vermeiden!
Set InversRange = Nothing
End Function
Private Function Invers_Area(act_select As Range) As Range
On Error Resume Next
Dim part1 As Range
Dim part2 As Range
Dim part3 As Range
Dim part4 As Range
Dim p As Integer
p = 0
If act_select.Row > 1 Then
Set part1 = Rows("1:" & act_select.Row - 1)
p = 1
End If
If act_select.Row + act_select.Rows.Count - 1 < 65536 Then
Set part2 = Rows(act_select.Row + act_select.Rows.Count & ":65536")
p = p + 2
End If
If act_select.Column > 1 Then
Set part3 = Range(Columns(1), Columns(act_select.Column - 1))
p = p + 4
End If
If act_select.Column + act_select.Columns.Count - 1 < 256 Then
Set part4 = Range(Columns(act_select.Column + _
act_select.Columns.Count), Columns(256))
p = p + 8
End If
Set Invers_Area = Nothing
Do While p > 0
Select Case p
'so gefällt es mir inzwischen besser - einfach auf den Kopf gestellt!
Case Is >= 8:
If Invers_Area Is Nothing Then
Set Invers_Area = part4
Else
Set Invers_Area = Union(Invers_Area, part4)
End If
p = p - 8
Case Is >= 4:
If Invers_Area Is Nothing Then
Set Invers_Area = part3
Else
Set Invers_Area = Union(Invers_Area, part3)
End If
p = p - 4
Case Is >= 2:
If Invers_Area Is Nothing Then
Set Invers_Area = part2
Else
Set Invers_Area = Union(Invers_Area, part2)
End If
p = p - 2
Case 1:
If Invers_Area Is Nothing Then
Set Invers_Area = part1
Else
Set Invers_Area = Union(Invers_Area, part1)
End If
p = p - 1
End Select
Loop
End Function
--
Regards
Thomas Ramel
- MVP for Microsoft-Excel -
[Win XP Pro SP-1 / xl2000 SP-3]
keepITcool
For discussion: this is my current Procedure..
I'm gonna check on Thomas Ramel's code posted a few mins ago..
Function Invert(rngA As Range, Optional bUsedRange As Boolean, _
Optional rngB As Range) As Variant
' Author keepITcool
' Adapted from Norman Jones 2004 Jul 22 'Invert Selection
' Adapted from thread 2003 Oct 12 'Don't Intersect
' thread contributors Tom Ogilvy, Dave Peterson, Dana DeLouis
Dim lCnt&, cVal As Collection, vItm As Variant
Dim rUni As Range, rInt As Range, rRes As Range
Dim iEvt%, iScr%
With Application
iEvt = .EnableEvents: .EnableEvents = False
iScr = .ScreenUpdating: .ScreenUpdating = False
End With
Set cVal = New Collection
If rngB Is Nothing Then
If bUsedRange Then
Set rngB = rngA.Parent.UsedRange
Else
Set rngB = Square(rngA)
End If
End If
'2707: change to prevent inverting solid
' : 1st errtrap if rngA was passed via SpCells
On Error GoTo theErrors
Set rInt = Intersect(rngA, rngB)
If rInt.Areas.Count = 1 Then Err.Raise vbObjectError + 1
Set rUni = Union(rngA, rngB)
With rUni
On Error Resume Next
lCnt = rUni.SpecialCells(xlCellTypeAllFormatConditions).Areas.Count
On Error GoTo theErrors
If lCnt = 0 Then
'No existing Format conditions..
rUni.FormatConditions.Add 1, 3, 0
Intersect(rngA, rngB).FormatConditions.Delete
Set rRes = .SpecialCells(xlCellTypeAllFormatConditions)
rRes.FormatConditions.Delete
Else
Do
'Loop thru existing Validations
'Recurse Samevalidation store in cVal
On Error Resume Next
lCnt = 0
lCnt = .SpecialCells(xlCellTypeAllValidation).Count
On Error GoTo theErrors
If lCnt = 0 Then Exit Do
With Intersect(rUni, _
rUni.SpecialCells(xlCellTypeAllValidation) _
.Cells(1).SpecialCells(xlCellTypeSameValidation))
With .Validation
'Note this is not bulletproof.. needs more testing
cVal.Add Array(.Parent, _
.Type, .AlertStyle, .Operator, .Formula1,
.Formula2, _
.IgnoreBlank, .InCellDropdown, _
.ShowError, .ErrorTitle, .ErrorMessage, _
.ShowInput, .InputTitle, .InputMessage)
.Delete
End With
End With
Loop
'This is what we came for..
.Validation.Add 0, 1
Intersect(rngA, rngB).Validation.Delete
Set rRes = .SpecialCells(xlCellTypeAllValidation)
rRes.Validation.Delete
'Restore original validations
If cVal.Count > 0 Then
For Each vItm In cVal
With vItm(0).Validation
.Add vItm(1), Abs(vItm(2)), vItm(3), vItm(4), vItm(5)
.IgnoreBlank = vItm(6)
.InCellDropdown = vItm(7)
.ShowError = vItm(8)
.ErrorTitle = vItm(9)
.ErrorMessage = vItm(10)
.ShowInput = vItm(11)
.InputTitle = vItm(12)
.InputMessage = vItm(13)
End With
Next
End If
End If
End With
theExit:
With Application
.EnableEvents = iEvt
.ScreenUpdating = iScr
End With
If ObjPtr(rRes) > 0 Then
If rRes.Areas.Count > 1 Then
Set Invert = rRes
Else
On Error Resume Next
lCnt = Intersect(rngA, rRes).Areas.Count
On Error GoTo theErrors
If lCnt = 0 Then
Set Invert = rRes
Else
Set rRes = Nothing
Err.Raise vbObjectError + 2
GoTo theErrors
End If
End If
End If
Exit Function
theErrors:
Select Case Err.Number
Case vbObjectError + 1: vItm = "Solid input range. Cannot invert."
Case vbObjectError + 2: vItm = "Complex result range. Cannot invert."
Case Else: vItm = Err.Description
End Select
Invert = CVErr(xlErrRef)
MsgBox vItm, vbCritical, "Error:Inverse Function"
Resume theExit
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
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Norman Jones wrote :
> Hi KeepItCool,
keepITcool
Grüezi Thomas!
.. bin noch dran das ding zu testen.
Thanks for posting this BUT
compared to the procedures posted earlier in this thread
.. which use specialcells and validation/formatconditions.
your code is WAY too slow...
(admittedly on a COMPLEX multiarea.. but that's where our existing idea
is having problems, because of an bug in specialcells (untrappable
error returns a solid range iso a multiarea with more than 8192 areas.)
see.. <news:xn0dl9eh4...@msnews.microsoft.com> solves in seconds
what your code takes minutes to do.(if it ever gets there cuz I crashed
it after it was burning my cpu.. 10 minutes at full throttle.. <g>
I'm happy with the things we have. Just neeed a final fix for complex
multiaareas.
Also...bin nicht mehr dran es zu testen. es hat jetzt 6 minuten
gelaufen.. und erst 3500 von 9000 areas gefunden...
Leider....
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Thomas Ramel wrote :
Peter T
I've been warming more and more to your DV Collection idea
when CF is not an option. The only reservation I have
remains replacing "jumbled" areas of validation (albeit
with correct DV).
What would you think of this as a minor adaption of your
Invert function:
Instead of storing / replacing DV in "rUni", first do -
Set rSqUni = Square(rUni)
and store / replace DV in rSqUni
Would speed be:
A: slower due to the extra use of the Square function and
quantity of DV in the larger range,
or
B: quicker because "probably" there would be a smaller
number of areas of DV in the square range,
or
C: depends?
With very limited testing I seem to end up with original
DV area(s).
Regards,
Peter
>-----Original Message-----
>..Formula2, _
Thomas Ramel
keepITcool schrieb am 27.07.2004
> Thanks for posting this BUT
>
> compared to the procedures posted earlier in this thread
> .. which use specialcells and validation/formatconditions.
>
> your code is WAY too slow...
I thougt so, but posted it anyway
> (admittedly on a COMPLEX multiarea.. but that's where our existing idea
> is having problems, because of an bug in specialcells (untrappable
> error returns a solid range iso a multiarea with more than 8192 areas.)
>
> see.. <news:xn0dl9eh4...@msnews.microsoft.com> solves in seconds
> what your code takes minutes to do.(if it ever gets there cuz I crashed
> it after it was burning my cpu.. 10 minutes at full throttle.. <g>
>
> I'm happy with the things we have. Just neeed a final fix for complex
> multiaareas.
I didn't read and study all the posts in the thread, but would like to
'borrow' the code for an add-in i lately wrote.
In there I'm able to reduce a multi-area selection by selecting the cells I
marked and sidn't wanted to.
> Also...bin nicht mehr dran es zu testen. es hat jetzt 6 minuten
> gelaufen.. und erst 3500 von 9000 areas gefunden...
>
> Leider....
No harm done to me, just my 2c.
keepITcool
Thx for helping me here :)
I didnt see where your 'Jumbling Protest' came from,
since I'm only testing with a PURE invert (sans RngB)
and haven't tested on a 'Complement' style inversion.
To keep efficiency..
I changed as follows:
'added
dim rSqu as range
...In the beginning..
If rngB Is Nothing Then
If bUsedRange Then
Set rngB = rngA.Parent.UsedRange
Else
Set rngB = Square(rngA)
End If
'ADD THIS LINE
Set rSqu = rngB
End If
...Then IN THE ELSE part..
Else
'2707b added SquareUnion
If ObjPtr(rSqu) = 0 Then Set rSqu = Square(rUni)
Do
'StoreDV (recurse samevalidation,store in collection)
On Error Resume Next
lCnt = 0
lCnt = .SpecialCells(xlCellTypeAllValidation).Count
On Error GoTo theErrors
If lCnt = 0 Then Exit Do
With Intersect(rSqu, rSqu _
.SpecialCells(xlCellTypeAllValidation) _
.Cells(1).SpecialCells(xlCellTypeSameValidation))
With .Validation
'2707b..probs gone? when dv add changed to 3
cVal.Add Array(.Parent, _
.Type, .AlertStyle, .Operator, .Formula1,
.Formula2, _
.IgnoreBlank, .InCellDropdown, _
.ShowError, .ErrorTitle, .ErrorMessage, _
.ShowInput, .InputTitle, .InputMessage)
.Delete
End With
End With
Loop
'This is what we came for..
'2707b changed added validation
.Validation.Add 0, 3, , 0
Intersect(rngA, rngB).Validation.Delete
Set rRes = .SpecialCells(xlCellTypeAllValidation)
rRes.Validation.Delete
'Restore original validations
...rest unchanged
I must admit though.. I have a very nasty testfile..
(basically an alternating /1/blank)
with left and right DVs and FCs dropped in..
Following HAS happened:
due to editing or while testing I apparently damaged/copied not removed
some dummy validation
and it has bogged somewhere in the collectDV Do/Loop
but this may be due to the fact that the DalataValidation was
"damaged ?" BEFORE i ran the sub.
when I called it with rngA set to:
union([a:a5000].SpC(blanks),[a10000:a15000].Spc(blanks))
it READ a range where all Properties in the SameValidation range
indicating <appl defined errors> so perhaps that indicates
a doevents is needed to give Excel time to recalc the tree ???
i assume SpeciallCells works on an cached index..
--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam
Peter T wrote :
Peter T
>I didnt see where your 'Jumbling Protest' came from,
>since I'm only testing with a PURE invert (sans RngB)
>and haven't tested on a 'Complement' style inversion.
Hardly a protest!
At most it's a trivial issue. Indeed for you it probably
won't arise as you are only going for the "Invert", the
title of this thread. However this code has bigger
possibilities - potentially will work well for subtracting
any intersecting ranges where either or both are
multiarea.
The basic principle has been discussed several times in
this NG (notably Dana DeLouis), but I think this is
working towards the best overall implementation, including
a lot of stuff I've done myself (not posted). Downside -
I'm going to have to re-work of my old code (:
So, I'm using avec un multi RngB - and getting un mélange
(with the Collection but not Array). I think using the
square will clear this up.
I'm currently having some problems with latest amendment
2707b and rSqu, Need to ensure all DV is collected from
the square range, then entirely deleted in the Square, do
stuff, then DV restored to the Square. Probably me missing
something obvious.
>Following HAS happened:
>due to editing or while testing I apparently
damaged/copied not removed
>some dummy validation
Funny you should mention that. I've experienced similar
but ignored. Here's something else:
I have a recorded macro to replace identical DV to a
single area over everything before testing. But
occasionally it errors and I need to run the
line ".Delete" (DV) twice. I've got a feeling similar has
occurred in proper code without my knowing. I'm only
testing with small ranges - visible on the screen,
shouldn't need DoEvents.
If you can re-produce your "HAS", try adding a
second .Delete line before applying any DV.
Regards,
Peter
Peter T
Partial diagnosis: DV is being restored twice in
overlapping areas, at least that's what's occuring in my
testing. Work with something manageable and look at:
If colDV.Count > 0 Then
For Each itm In colDV
Debug.Print itm(0).Address, itm(0).Count, _
itm(0).Areas.Count
or compare [count] with [sum areas.count]
This is in "Invert" pre "rSqu" amendment, and similar in
the amendment with vitm(0). I say "partial" because
there's also something else going on, I think all easily
fixed but far too late tonight.
regards,
Peter
>
>>Following HAS happened:
>>due to editing or while testing I apparently
>damaged/copied not removed
>>some dummy validation
>
>Funny you should mention that. I've experienced similar
>but ignored. Here's something else:
>
>I have a recorded macro to replace identical DV to a
>single area over everything before testing. But
>occasionally it errors and I need to run the
>line ".Delete" (DV) twice. I've got a feeling similar has
>occurred in proper code without my knowing. I'm only
>testing with small ranges - visible on the screen,
>shouldn't need DoEvents.
>
>If you can re-produce your "HAS", try adding a
>second .Delete line before applying any DV.
>
>Regards,
>Peter
>.
>
jim.wilcox
For your amusement...
Sub Test()
NotIntersect(Selection, Application.InputBox("", , , , , , ,
8)).Select
End Sub
Function NotIntersect(rng As Range, x As Range) As Range
' copyright 2001-2004 Jim Wilcox
Dim y As Range
On Error Resume Next
If rng.Parent Is x.Parent Then
With x
Set y = myUnion(y, Range(Rows(1), .Rows(0)))
Set y = myUnion(y, Range(Rows(Rows.Count), .Rows(.Rows.Count +
1)))
Set y = Intersect(y, .EntireColumn)
Set y = myUnion(y, Range(Columns(1), .Columns(0)))
Set y = myUnion(y, _
Range(Columns(Columns.Count), .Columns(.Columns.Count + 1)))
Set y = Intersect(y, rng)
End With
Set NotIntersect = y
End If
On Error GoTo 0
End Function
Private Function myUnion(o As Range, rng As Range) As Range
On Error Resume Next
If o Is Nothing Then
Set myUnion = rng
ElseIf rng Is Nothing Then
Set myUnion = o
Else
Set myUnion = Union(o, rng)
End If
On Error GoTo 0
End Function
-Jim (see Organization field to figure out email address)
Peter T
I suspect KeepITcool is doing the sensible thing and gone
on holiday, hence a reply from me.
This looks interesting but I cannot get it to work
correctly, a dot or two out of place perhaps. I had a go
with something similar, didn't pursue when KeepITcool
warned me off the idea (with large ranges).
As time's gone by a quick recap -
To get a pure inverted range, eg
Set RngA = Range("b2:c3,f3:g4")
Set RngB = Range("b2:g4") 'square or outer RngA
Set rInverted = rFunc(RngA, RngB)
Debug.? rInverted.Address
$B$4:$C$4,$D$2:$E$4,$F$2:$G$2
For my, and I think Norman's purposes, to subtract ranges
whose "outer" areas may only partially intersect. Also,
either/both ranges could be single or multiple. The
functions in this thread are set up to subtract Intersect
(RngA,RngB) from Union(RngA,RngB), but easily adapted to
subtract whatever. Eg:
Set RngA = Range("B2:C3,F3:G4")
Set RngB = Range("B3:B5,C3:G3")
Set rSubtracted = rFunc(RngA, RngB)
' subtract Intersect from Union
Debug.? rSubtracted.address
$F$4:$G$4,$B$4:$B$5,$B$2:$C$2,$D$3:$E$3
I would expect your code to be slower than the methods
discussed, but good for smaller ranges to avoid using DV
or CF. As it stands it does not appear to return the non-
intersecting areas of the ranges thrown at it. I'm hoping
I've missed something obvious and looking forward to one
of those Doh moments :)
Regards,
Peter
>.
>
jim.wilcox
> correctly, a dot or two out of place perhaps.
No.
If you can't get it to work let me help. What was the error message and
line?
-Jim
Peter T
Jim,
Not directly a code halting with an error but more a case
of as I also mentioned last post:
>>As it stands it does not appear to return the non-
>>intersecting areas of the ranges thrown at it.
With the examples I posted:
Sub test2()
Dim RngA As Range, RngB As Range
Set RngA = Range("b2:c3,f3:g4")
Set RngB = Range("b2:g4") 'square or outer RngA
Set RngA = NotIntersect(RngA, RngB)
RngA.Select
Debug.Print RngA.Address
End Sub
Here, RngA.Select errors because, in your func:
Set y = Intersect(y, rng) is a non intersecting range,
hence the function returns a non existant range.
Or,
Set RngB = Range("B2:C3,F3:G4")
Set RngA = Range("B3:B5,C3:G3")
Set RngA = NotIntersect(RngA, RngB)
RngA.address returns: B4:B5,D3:G3
Instead of: F4:G4,B4:B5,B2:C2,D3:E3 ($'s trimmed)
Have I missed something?
Regards,
Peter
jim.wilcox
Yes.
Function NotIntersect(rng As Range, x As Range) As Range
rng is the source
x is the range to be removed from the source
I presented the function in such a way that x should be a single-area
range, because calling the function within a loop...
for each x in bigx.Areas
NotIntersect(Selection, x).Select
...or whatever, would be a trivial exercise for the reader, and would
detract from understanding the basic and very simple concept of what my
code achieves, extremely efficiently.
-Jim
Norman Jones
> I presented the function in such a way that x should be a single-area
> range, because calling the function within a loop...
>
> for each x in bigx.Areas
> NotIntersect(Selection, x).Select
>
> ...or whatever, would be a trivial exercise
In his initial post in this thread, KeepITcool explicitly excluded the loop
approach:
>>It MUST be fast.. thus a simple loop will never suffice.
>>unions above 400 areas get dreadfully slow..
This need is reinforced by the repeated discussion in the thread of the 8192
non-contiguous areas bug in conjunction with comments such as the following
(from KeepITCool):
> 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 !
I suspect that testing your function in similar fashion would highlight the
fundamental problem.
My plagiaristic approach and those of Peter and KeepITcool were all
predicated on a fast non-looping solution.
---
Regards,
Norman
Peter T
Thank you for clarifying, I had been hoisted by a series
of self induced presumptions.
Although you introduced this as "For your amusement..." it
is, as you say, extremely efficient.
However I think not efficient to deploy with a large loop
of areas the way you suggest. Eg to return the non-
intersection of bigx and the single area that perfectly
surrounds it - Invert a multiple range.
With 100 areas the increased time compared with other
methods is of no consequence, with the advantage of
requiring neither DV nor CF. But with say 4,000 areas, in
my testing, about a hundred times longer than the few
seconds required using DV subtraction, or similar with
KeepITcool's CF method. I don't think I've misunderstood
anything this time, but if I have please advise.
Once again thank you for posting the code,
Peter
PS written before seeing Norman's adjacent post
>
>I presented the function in such a way that x should be a
single-area
>range, because calling the function within a loop...
>
>for each x in bigx.Areas
> NotIntersect(Selection, x).Select
>
>....or whatever, would be a trivial exercise for the
reader, and would
>detract from understanding the basic and very simple
concept of what my
>code achieves, extremely efficiently.
>
>-Jim
>.
>
Myrna Larson
I was intrigued by your code. I tried it with the following
Sub Test()
Dim R As Range
Set R = NotIntersect(Range("a2:d5"), Range("b3:c4"))
If R Is Nothing Then
MsgBox ("Nothing!")
Else
MsgBox R.Address
End If
Set R = NotIntersect(Range("b3:c4"), Range("a2:d5"))
If R Is Nothing Then
MsgBox ("Nothing!")
Else
MsgBox R.Address
End If
End Sub
The first call works fine -- it would select all cells in A2:D5 except B3:C4.
The 2nd line SHOULD produce the same result, right? But it doesn't. It returns
Nothing.
Also, if I call it with ranges A2:D5 and B3:D6, in that order, it does not
include cells B6:D6, which are part of the 2nd range but not of the 1st.
The routine would seem to require that the one range is entirely included in
the other, and the larger range must be specified first. Was that your intent?
jim.wilcox
> KeepITcool explicitly excluded the loop
> approach:
>
> >>It MUST be fast.. thus a simple loop will never suffice.
> >>unions above 400 areas get dreadfully slow..
NotIntersect solves 400 areas in less than a second.
> repeated discussion in the thread of the 8192
> non-contiguous areas bug
Do we have a solution that solves 8000? NotIntersect does, but I do see
that it takes too long -- many minutes. Forgive me, but do we need one?
I don't read this newsgroup. I saw the original post in this thread
during a search for something else, so I haven't read this bug
discussion. FWIW, is it a bug? There are many things that spreadsheets
aren't intended to do, and while it's fun to challenge the boundaries,
perhaps it's also helpful to provide pointers to the more appropriate
application(s).
-Jim
jim.wilcox
Yes.
-Jim (see Organization field to figure out email address)
P.S. I come from the old school of usenet. I mean, for questions like
these, it seems to me that email is more appropriate, no?
Peter T
>Do we have a solution that solves 8000?
KeepITcool does for his particular purpose, see
SegmentedCells in one of his posts. I havn't figured how
to adapt this for more generic use. I think Norman was
working on something, privately - ? and a <g>
>NotIntersect does, but I do see that it takes too long --
>many minutes. Forgive me, but do we need one?
Absolutely. For me not often 8000+ but certainly something
fast for x000.
>FWIW, is it a bug? [re 8192 limit]
In Excel this may be a sensible design limitation. F5
select 8000+ areas severely strains resources, assuming no
other constraints which there probably are.
But in VBA no error is returned if the limit is exceeded,
incorrectly returns just the first cell. I'd call that a
bug. This contrasts with:
a) in vba, no cells found - generates trappable error
b) Excel only, 8192+ generates Alert "selection too large"
Something simple like count constants and one cell is
returned, how to know if that's correct. Norman
demonstrated the limit could even be 8191 ! and
additionally a solution to trap the problem.
Back to your function, my results in an old system
(reducing outer-bigx with bigx by areas):
Areas NotIntersect DV or CF method
400 1 sec 0.1 s
1000 15 s 0.5 s
4000 800 s 6 s
Self evident. But I would not bet against the possibility
your function could be radically adapted to reduce the
time by a factor of 2 to 10, depending on no. of areas.
Regards,
Peter
Myrna Larson
>these, it seems to me that email is more appropriate, no?
I don't agree. I thought the purpose of these discussions was to help other
users. Seeing only part of the discussion doesn't help them...
Myrna Larson
I haven't followed this thread.
Given the name, NonIntersect, I expected the routine to take two ranges,
create their union, then remove their intersection.
I see from your comments in another message that you want to take the first
range and remove from it any cells that are also part of the 2nd range. That's
not the problem I expected, but presumably it's what the OP wanted.
Myrna Larson
If I display the header fields, the organization field gives your company
name, not your email address at the company. I use Agent as my newsreader.
Perhaps Outlook Express is different.