Norman,
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 :
4,E5:E6,B7:B8")