Wizards,

I need some help on extracting the specific range of data from an excel sheet (attached) to pass on to the function to get randomly sampled data using patrick mathews code.

I tried developing a module (code below) but instead of transferring contents to a new sheet, i wanted to shuffle rows, mix and reorder them in the source sheet itself. I landed up in a bit of mess most of the time shuffling the contents within the sheet, that's why i tried transferring contents to the new sheet.

Here's the criteria on which i want to extract data for sampling:

There a column called LAST_UPDATE_NAME where a list of names exist.

To get data in a continuous range for sampling, I may need to apply filters to drill down to a final set of data. This final set required should be in a continuous range. Filtering can be done upto 3 or 4 levels.

Initially, need to sort the names column and then by filtering by each name and to get a continuous range of data, i drill down based on various other columns such as KYL_ML_SCORE, ORG_UNIT_NAME, NOTES, RISK WEIGHTING, etc.

I want to get the filtered output (data) in a continous range. At any given time, after filtering by the names column, i may drill down to the final set of data by applying filter to one or more of the above four columns.

Here's the code which i tried out:

[vba]
Sub Filter_N_Transfer()
Dim ACell As Range
Dim WSNew As Worksheet
Dim Rng As Range
Dim ActiveCellInTable As Boolean
Dim nameX As String
Dim f As Filter
Dim w As Worksheet
Const ns As String = "Not Set"
rw = 1
For Each f In ActiveSheet.AutoFilter.Filters
If f.On Then
c1 = Right(f.Criteria1, Len(f.Criteria1) - 1)
If f.Operator Then
op = f.Operator
c2 = Right(f.Criteria2, Len(f.Criteria2) - 1)
Else
op = ns
c2 = ns
End If
Else
c1 = ns
op = ns
c2 = ns
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set ACell = ActiveCell
'nameX = Application.InputBox(Prompt:="Name of the Sheet")
'If nameX = " " Then Exit Sub
ACell.Select
' Copy the Visible data into a new worksheet.
If ActiveCellInTable = False Then
On Error Resume Next
ACell.Parent.AutoFilter.Range.Copy
If Err.Number > 0 Then
MsgBox "Select a Cell in your Data Range"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End If
Else
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
End If
' Add a new worksheet to copy the Filtered Results
Set WSNew = Worksheets.Add
' Add InputBox to get destination Sheet Name
WSNew.Name = c1 + c2
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
' Close AutoFilter.
ACell.AutoFilter
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Next
End Sub
[/vba]


Can someone help me fix up the above code??

Sarang