Keeping Validation References When Breakingout Spreadsheets

[ScottMSP via OfficeKB.com]

Hello,
I am using a version of Ron Debruin’s macro that breaks out spreadsheets into

separate spreadsheets using a filter on a selected column.

The issue that I am having is that I have a series of validation references
located in the original sheet in hidden rows (rows 1-14 are hidden). I need
to
be able to retain these references in all the newly created sheets and retain

the fixed references.

To clarify, for each sheet that is broken out based on the macro below, I
also need to have the first 14 lines copied from the original master sheet
and inserted on each new worksheet on lines 1 -14 and then the specific
filtered information to be pasted into the worksheet. This is so that the
filtered information, that have validations in certain cells, can continue to
reference the validation lookups in rows 1 - 14.

How do I do this?

Thanks in advance.

Modified Ron Debruin Macro
Sub FPR_Breakout_Worksheets()
Dim calcmode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Lrow As Long
Dim FieldNum As Integer

'Name of the sheet with your data
Set ws1 = ActiveSheet '<<< Change

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set Rng = ws1.Range("A14:AM" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 1

With Application
calcmode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add

With ws2
'first we copy the Unique data from the filter field to ws2
Rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each Cell In .Range("A3:A" & Lrow)

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = Cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
Rng.AutoFilter Field:=FieldNum, Criteria1:="=" & Cell.Value

'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Close AutoFilter
ws1.AutoFilterMode = False

Next Cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

With Application
.ScreenUpdating = True
.Calculation = calcmode
End With
End Sub