Hi John,
Try using the following two functions:
'==================>>
Function Invert(rngA As Range, Optional bUsedRange As Boolean, _
Optional rngB As Range) As Variant
' Author keepITcool
http://tinyurl.com/agpz9
' 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
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
'<<=================
As an example of use, assume that the initial population range comprises
rows 1:100 and that the retained range comprises the randomly selected rows
9, 43, 84:
'================>>
Sub TestIt()
Invert(Range("A1:A100"), , Range("A9, A43,A84")). _
EntireRow.Delete
End Sub
'<<================
