Delete Non-Randomly Chosen Rows

I am using a random number generator to pull a sample of rows from a larger
population. I use the Excel row numbers for the RNG. From here I've been
adding a field and marking it with X then filtering to get my list of
samples. This is cumbersome at best.

Is there a way I can get Excel to delete entire rows based on a list I
provide? e.g the RNG comes up with 9, 43, 84, etc. I want to delete all rows
EXCEPT 9, 43, 84, etc. I want something I can copy and past the row numbers
as a group into. The originial number of rows is dynamic and keep in mind
that what was row 43 will become row 10 after the other rows are deleted so
maybe it needs to start at the bottom.

Help will be appreciated by many.

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

---
Regards,
Norman




"John" <[email protected]> wrote in message
news:[email protected]...
>I am using a random number generator to pull a sample of rows from a larger
> population. I use the Excel row numbers for the RNG. From here I've been
> adding a field and marking it with X then filtering to get my list of
> samples. This is cumbersome at best.
>
> Is there a way I can get Excel to delete entire rows based on a list I
> provide? e.g the RNG comes up with 9, 43, 84, etc. I want to delete all
> rows
> EXCEPT 9, 43, 84, etc. I want something I can copy and past the row
> numbers
> as a group into. The originial number of rows is dynamic and keep in mind
> that what was row 43 will become row 10 after the other rows are deleted
> so
> maybe it needs to start at the bottom.
>
> Help will be appreciated by many.