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.. 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 :

Grüezi keepITcool

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