creating separate worksheets

[tariq1]

Hi,

In the attached I have a list of employees from different countries:

CAN
ESP
FR
GER
UK
US

The country code is in Column B.

I would like a macro which takes this workbook and creates 6 different workshhets
for each country, with each worksheet containing employees from that respective country

Thank yoiuo

[StephenR]

There is no attached. A workbook would be helpful.

[royUK]

Here's some code that I use for this job, you will need to change Column references

'Option Explicit

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 24/09/2006 22:48
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheet1

    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 9).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count)    'move to end
                wsNew.Name = sNm
            End If
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=3, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

[royUK]

This works in your example

Option Explicit

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 24/09/2006 22:48
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheet1

    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 7).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count)    'move to end
                wsNew.Name = sNm
            End If
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=3, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

I'll add some code to separate workbooks later