Macro to copy specific data,paste it into a new spreadsheat and save it with a specific filename

[scorp116]

Hello,
I am looking for a macro that will copy data based on a specific cell(group name) and paste it to a new workbook. I am also looking for the ability to save the new workbooks with the same filename as the original, with the addition of an underscore and the group name at the end of the filename.
Here is an example of the format of the data (column B is the Group Name)
A B C D E F G H ....
x 1 x x x x x x
x 1 x x x x x x
x 2 x x x x x x
x 2 x x x x x x
x 2 x x x x x x
x 3 x x x x x x
x 3 x x x x x x
x 4 x x x x x x
x 4 x x x x x x
x 4 x x x x x x
x 4 x x x x x x
x 5 x x x x x x
x 5 x x x x x x
The original Filename is List_2011-11-10
The original file and filename will be manually created everyday.

I need the new files to only have each specific group (along with the header) and to be saved as so
List_2011-11-10_1
List_2011-11-10_2
List_2011-11-10_3
List_2011-11-10_4
List_2011-11-10_5
I appreciate any help that can be provided to me. If you need any more information, please let me know

 

[TheVillageIdiot]

This creates the file names based upon today's date and saves them to the same directory where the active workbook resides. Change the parameters as required.

Sub test()
Const kstrFilePrefix As String = "List_"
Const RefCol As Long = 2 '' this is the group name column

Dim strPath As String
Dim wkbk As Workbook, wks As Worksheet
Dim NewWkbk As Workbook, strNewFileNm As String
Dim lngLastRow As Long, lngLastCol As Long
Dim iSheets
Dim RngData As Range, i As Long
Dim strAppend1 As String, arrGroup, Cnt As Long

strAppend1 = Format(Date, "yyyy-mm-dd")

With Excel.Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    iSheets = .SheetsInNewWorkbook
    .SheetsInNewWorkbook = 1
    
    
    Set wkbk = .ActiveWorkbook
    With wkbk
        strPath = .Path & Application.PathSeparator
        Set wks = .ActiveSheet
    End With
    
    With wks
        .AutoFilterMode = False
        lngLastRow = .Cells(.Rows.Count, RefCol).End(xlUp).Row
        lngLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ReDim arrGroup(1 To lngLastRow)
        For i = 2 To lngLastRow
            If IsError(Application.Match(.Cells(i, RefCol), arrGroup, 0)) Then
                Cnt = Cnt + 1
                arrGroup(Cnt) = .Cells(i, RefCol)
                
                strNewFileNm = strPath & kstrFilePrefix & strAppend1 & "_" & arrGroup(Cnt)
                
                With .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=arrGroup(Cnt)
                
                    With wks
                        Set RngData = Intersect(.Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol)), _
                            .Cells.SpecialCells(xlCellTypeVisible))
                        Set NewWkbk = Application.Workbooks.Add
                        RngData.Copy NewWkbk.Sheets(1).Cells(1, 1)
                    End With
                End With
                .AutoFilterMode = False
                With NewWkbk
                    .SaveAs (strNewFileNm)
                    .Close
                End With
                Set NewWkbk = Nothing
            End If
        Next
    End With

End With

    Erase arrGroup
    Set wks = Nothing
    Set wkbk = Nothing
    
    With Excel.Application
        .ScreenUpdating = True
        .DisplayAlerts = False
        .SheetsInNewWorkbook = iSheets
    End With
    
End Sub