I'm not quite sure wot u mean, this is the code the Supplier tab ... ca
u elaborate from this ? I've got the Supplier macro running from
button and want another button in the customer tab ...

Sub Split_Supplier_Codes()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Supplier")
Set rng = Range("Database")

'extract a list of Code Nos
ws1.Columns("A:A").Copy _
Destination:=Range("Z1")
ws1.Columns("Z:Z").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("A1").Value

For Each c In Range("X2:X" & r)
'add the code no to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set WSNew = Sheets.Add
WSNew.Move After:=Worksheets(Worksheets.Count)
WSNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=True
End If
Next
ws1.Select
ws1.Columns("Y:Z").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

Cheers :confused

--
GazM
-----------------------------------------------------------------------
GazMo's Profile: http://www.excelforum.com/member.php...fo&userid=1461
View this thread: http://www.excelforum.com/showthread.php?threadid=26926

Hi GazMo

My example will filter on the first column of the range
(in my example is this column A because my range only have one column)
If your range is bigger like A1:G100 and you want to filter on column B you must
change this line
rng.Columns(1).AdvancedFilter _
to
rng.Columns(2).AdvancedFilter _

My macro use the LastRow function to find the last row with data if
the sheet exist.
The new data will be paste below the existing data


--
Regards Ron de Bruin
http://www.rondebruin.nl


"GazMo" wrote in message ...

I'm not quite sure wot u mean, this is the code the Supplier tab ... can
u elaborate from this ? I've got the Supplier macro running from a
button and want another button in the customer tab ...

Sub Split_Supplier_Codes()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Supplier")
Set rng = Range("Database")

'extract a list of Code Nos
ws1.Columns("A:A").Copy _
Destination:=Range("Z1")
ws1.Columns("Z:Z").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("A1").Value

For Each c In Range("X2:X" & r)
'add the code no to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set WSNew = Sheets.Add
WSNew.Move After:=Worksheets(Worksheets.Count)
WSNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=True
End If
Next
ws1.Select
ws1.Columns("Y:Z").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

Cheers


--
GazMo
------------------------------------------------------------------------
GazMo's Profile: http://www.excelforum.com/member.php...o&userid=14610
View this thread: http://www.excelforum.com/showthread...hreadid=269267

Hi GazMo

Give me your filter range and the filter column and I will make a new example

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" wrote in message ...

Hi GazMo

My example will filter on the first column of the range
(in my example is this column A because my range only have one column)
If your range is bigger like A1:G100 and you want to filter on column B you must
change this line
rng.Columns(1).AdvancedFilter _
to
rng.Columns(2).AdvancedFilter _

My macro use the LastRow function to find the last row with data if
the sheet exist.
The new data will be paste below the existing data


--
Regards Ron de Bruin
http://www.rondebruin.nl


"GazMo" wrote in message ...

I'm not quite sure wot u mean, this is the code the Supplier tab ... can
u elaborate from this ? I've got the Supplier macro running from a
button and want another button in the customer tab ...

Sub Split_Supplier_Codes()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Supplier")
Set rng = Range("Database")

'extract a list of Code Nos
ws1.Columns("A:A").Copy _
Destination:=Range("Z1")
ws1.Columns("Z:Z").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("A1").Value

For Each c In Range("X2:X" & r)
'add the code no to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set WSNew = Sheets.Add
WSNew.Move After:=Worksheets(Worksheets.Count)
WSNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Supplier").Range("Z1:Z2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=True
End If
Next
ws1.Select
ws1.Columns("Y:Z").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

Cheers


--
GazMo
------------------------------------------------------------------------
GazMo's Profile: http://www.excelforum.com/member.php...o&userid=14610
View this thread: http://www.excelforum.com/showthread...hreadid=269267