Copy to Range Keeping Dropdown lists

[bthomas]

Hi is there a way to copy data at each change to separate sheets while keeping your validation cells in tact?

I have the following code, but it drops my dropdown lists.

[FONT=Calibri]Sub DatatoTABS()[/FONT]
[COLOR=black][FONT=verdana]Dim wsAll As Worksheet[/FONT][/COLOR]
[FONT=verdana][COLOR=black]Dim wsCrit As Worksheet[/COLOR][/FONT]
[FONT=verdana][COLOR=black]Dim wsNew As Worksheet[/COLOR][/FONT]
[FONT=verdana][COLOR=black]Dim LastRow As Long[/COLOR][/FONT]
[FONT=verdana][COLOR=black]Dim LastRowCrit As Long[/COLOR][/FONT]
[FONT=verdana][COLOR=black]Dim I As Long[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   Set wsCrit = Worksheets.Add[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   ' column G has the criteria eg project ref[/COLOR][/FONT]
[FONT=verdana][COLOR=black]   wsAll.Range("G1:G" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row[/COLOR][/FONT]
[FONT=verdana][COLOR=black]   For I = 2 To LastRowCrit[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]       Set wsNew = Worksheets.Add[/COLOR][/FONT]
[FONT=verdana][COLOR=black]       wsNew.Name = wsCrit.Range("A2")[/COLOR][/FONT]
[FONT=verdana][COLOR=black]       wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _[/COLOR][/FONT]
[FONT=verdana][COLOR=black]        CopyToRange:=wsNew.Range("A1"), Unique:=False[/COLOR][/FONT]
[FONT=verdana][COLOR=black]       wsCrit.Rows(2).Delete[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   Next I[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]   Application.DisplayAlerts = False[/COLOR][/FONT]
[FONT=verdana][COLOR=black]   wsCrit.Delete[/COLOR][/FONT]
[FONT=verdana][COLOR=black]   Application.DisplayAlerts = True[/COLOR][/FONT]
 
[FONT=verdana][COLOR=black]End Sub[/COLOR][/FONT]

Appreciate all of your help!