BA extract variable number of rows if content in one column is the same and save each new

Hello everyone,

Need someone to help me debug a problem I'm having with my code. I borrowed code (because I'm still learning) from Jbeaucaire because it looked like the code would work for a repetitive process I'm doing.

I want to create a macro that looks at the contents of a worksheet that will sort on the contents of Column B so that only two groups appear; Group A and Group B

Then I need the code to copy all of the rows (from A3 to Qxx) based on the same text in column B and put those rows in a new workbook and save it to my desktop with a specific name, text from Column B and date. Then return to the main worksheet and identify the next group and copy those rows into a new workbook.

Each new file will be labeled with either Request_Rows_to_submit_ group A_ 9.21.21.xls or Request_Rows_to_submit_ group B_ 9.21.21

Also I cannot dedicate the path to save the file because this file/VBA will be used by all of my team who are not saavy about VBA. They just want to click on the activate button and have it done.

Here is my code and it is stopping at the + 5. This is where I'm at a blank. How do I code to have excel capture all the rows A thru Q with the same text in column B?

Thank you all for your help in advance on this. Every time I use this site I learn something new that propels my VBA knowledge just a little bit further.

Bev

Sub MakeNewFile()
 
    Dim FName                As String
    Dim FPath                  As String
    Dim SubmissionRNG   As Range
    Dim C                       As Long

    Application.ScreenUpdating = False

    Set SubmissionRNG = Range("A3:Q" & Rows.Count).SpecialCells(xlConstants)
    
'   Sort Access Type
    Range("A5:P100").Sort key1:=Range("b5"), order1:=xlAscending, Header:=xlYes

'   Select group and copy to new worksheet
    For C = 1 To SubmissionRNG.Areas.Count
       Range("1:3").Copy
       Sheets.Add
       Range("A3").PasteSpecial
       SubmissionRNG.Areas(C).Resize(SubmissinRNG.Areas(C).Rows.Count + 5).EntireRow.Copy Range("A3")
       ActiveSheet.Move
       ActiveSheet.Paste
        Cells.Select
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A2").EntireRow.Insert
        Range("A9").Activate
        Columns("C:Q").ColumnWidth = 45
        Cells.Select
        ActiveWindow.Zoom = 75
       ActiveWorkbook.SaveAs CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & "Request_Rows_to_submit_" & FName & "_" & Format(CStr(Now()), "mm.dd.yy") & ".xlsx"

     Next C

    Application.ScreenUpdating = True

    MsgBox "Exported to Desktop"
    


End Sub