Dim CalcMode As Long
Dim ws1 As String
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
ws1 = InputBox("enter a sheet name")
MsgBox "Sheetname is " & ws1

'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 = Application.InputBox(prompt:="Select a cell", Type:=8)
MsgBox "Range selected is " & rng.Address

'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 = InputBox("enter a number")
MsgBox FieldNum

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("A2: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 ever so much!!!

--
Message posted using http://www.talkaboutsoftware.com/gro...eet.functions/
More information at http://www.talkaboutsoftware.com/faq.html

Hi

Try this:

Dim ws1Name As String
Dim ws1 As Worksheet
'Name of the sheet with your data
ws1Name = InputBox("enter a sheet name")
MsgBox "Sheetname is " & ws1Name
Set ws1 = Worksheets(ws1Name)

Best regards,
Per

Lilbit" skrev i meddelelsen
lkaboutsoftware.com...
Dim CalcMode As Long
Dim ws1 As String
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
ws1 = InputBox("enter a sheet name")
MsgBox "Sheetname is " & ws1

'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 = Application.InputBox(prompt:="Select a cell", Type:=8)
MsgBox "Range selected is " & rng.Address

'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 = InputBox("enter a number")
MsgBox FieldNum

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("A2: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 ever so much!!!

--
Message posted using
http://www.talkaboutsoftware.com/gro...eet.functions/
More information at http://www.talkaboutsoftware.com/faq.html

Thank you! Thank you!! Thank you!!!

--
Message posted using http://www.talkaboutsoftware.com/gro...eet.functions/
More information at http://www.talkaboutsoftware.com/faq.html