VBA Macro required for filtered data to a new sheet.

Could anyone help me to get macro for the following:
I have an excel data in a worksheet. I want this data to be filtered for column A header. Say for example "name" is the header for column A. Now this "name" should be filtered and the each of the filtered rows with their header are required to be copied in a new worksheet. The filtered cell value shall be given for the name for the new sheets.

Example: Here the Name A shall be filtered and copied in a new sheet"A", Name B to sheet"B", Name C to sheet"C".......to indefinite numbers.

Name Hd2 Hd3 Hd4 Hd5
A X1 X1 X1 X1
A Y1 Y1 Y1 Y1
A Z1 Z1 Z1 Z1
B X1 X1 X1 X1
B Y1 Y1 Y1 Y1
B Z1 Z1 Z1 Z1
C X1 X1 X1 X1
C Y1 Y1 Y1 Y1
C Z1 Z1 Z1 Z1
D X1 X1 X1 X1
D Y1 Y1 Y1 Y1
D Z1 Z1 Z1 Z1


Thank you friends,

Hi anbub1

This link does just as you describe...if you need help adapting please post your File.

http://www.excelforum.com/excel-prog...ual-files.html

Hi Anbub

Post your Code and one of us will look at it. Please remember to use Code Tags when you do so.

Hi Anbub

Try this Code. Please note, a Dynamic Named Range titled "ItemCode" has been added to Sheet Dummy... let me know of issues

Option Explicit
Sub CC_List()
    Dim wb As Workbook
    Dim newBook As Workbook
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim LR As Long
    Dim Rng As Range
    Dim cel As Range
    Dim myPath As String
    Dim SavePath As String
    Dim pw As String

    myPath = ThisWorkbook.Path & "\"
    SavePath = "D:\Products\"
    '    SavePath = "E:\Products\" '<---jaslake Path for testing...can be deleted

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Original")
    Set ws1 = Sheets("Dummy")

    Application.ScreenUpdating = False
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If

    With ws
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A2:A" & LR), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A2:I" & LR)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Columns(1).Copy Sheets("Lists").Range("A1")
        Sheets("Lists").Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
        ActiveWorkbook.Names.Add Name:="Depts", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"

        For Each cel In Range("Depts")
            .Range("A1:I" & LR).AutoFilter Field:=1, Criteria1:=cel

            Set newBook = Workbooks.Add(xlWBATWorksheet)

            With newBook
                With ws.Range("A1:I" & LR)
                    .Copy
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
                    newBook.Sheets(1).Name = cel
                End With

                With ws1.Range("ItemCode")
                    Set Rng = .Find(What:=cel, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                    If Not Rng Is Nothing Then
                        pw = Rng.Offset(0, 1).Value
                    Else
                        MsgBox "Password not found for " & cel & vbCrLf & "Password has been set to """
                        pw = ""
                    End If

                End With

                Application.DisplayAlerts = False
                .SaveAs SavePath & cel, FileFormat:=51, Password:=pw
                newBook.Close
                Application.DisplayAlerts = True
            End With
            .AutoFilterMode = False
        Next cel
        .AutoFilterMode = False
        Application.DisplayAlerts = False
        Sheets("Lists").Delete
        Application.DisplayAlerts = True
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Hi Anbub

As I pointed out here, you need to Create this Range

Please note, a Dynamic Named Range titled "ItemCode" has been added to Sheet Dummy

If you don't know how to do that let me know and I'll have the Code do it.

You're welcome...glad I could help.