Hi KeepITcool,

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


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, .Error
Message, _
.ShowInput, .InputTitle, .Input
Message)
.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