Try this Steve

Sub Copy_To_Worksheets_Test()
   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 = Sheets("Sheet1")  '<<< 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("A1:D" & 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

   ' Worksheet with the list of customers numbers in column A
   Set ws2 = Worksheets("control")

   With ws2

       'loop through the  list in ws2 and filter/copy to a new sheet
       Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
       For Each cell In .Range("A1: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 xlPasteValues
               .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

Thanks Ron!!

On Mar 21, 10:41 am, "Ron de Bruin" <rondebr...@kabelfoon.nl> wrote: