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

[Bevg]

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

[nankw83]

Hi Bevg,

Try below code ...

Sub test()

Dim Path$, Dic As Object, a, j$
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set Dic = CreateObject("scripting.dictionary")
   
With ThisWorkbook.Sheets("inital data").[A1].CurrentRegion
   a = .Value
   For x = 2 To UBound(a)
      j = a(x, 1)
      If Not Dic.exists(j) Then
         Dic.Add j, Nothing
         .AutoFilter 1, j
         .Copy Workbooks.Add.Sheets(1).[A1]
         ActiveWorkbook.Close True, Path & "Request_Rows_to_submit_" & j & "_" & Format(Date, "mm.dd.yy") & ".xlsx"
      End If
   Next
   .Parent.AutoFilter.ShowAllData
End With

End Sub

[Bevg]

Thank you for the quick response but I don't see when the code is selecting group A or group B.

[Bevg]

Resolved my problem.

[nankw83]

Did you try the code ? Is it working as expected or not ? Any errors ?

[Bevg]

Yes, it did work!
and the code was very concise. Wow!

THANK YOU SO MUCH! I will study this code to understand how it was able to sort the information and save it.

[Bevg]

Hello,
I did not solve my problem. I applied the code to the real file
I'm getting a type mismatch error at the code For x = 2 To Ubound(b)
Unfortunately, I'm still learning and Ubound is foreign to me at this
time.

The real file has the filter column start in column B row 4.
Also the results need to be saved in row A9.

I uploaded an example that shows exactly where the source date resides. Plus
the values in the filter column are different lengths, some 8 characters, some 4 characters, some 5 characters

Here are the changes I made to the code. I would really appreciate it if
someone can tell me where I went wrong.

Sub test()

Dim Path$, Dic As Object, a, j$
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set Dic = CreateObject("scripting.dictionary")
   
With ThisWorkbook.Sheets("inital data").[B4].CurrentRegion
   b = .Value
   For x = 2 To UBound(b)
      j = b(x, 1)
      If Not Dic.exists(j) Then
         Dic.Add j, Nothing
         .AutoFilter 1, j
         .Copy Workbooks.Add.Sheets(1).[A9]
         ActiveWorkbook.Close True, Path & "Request_Rows_to_submit_" & j & "_" & Format(Date, "mm.dd.yy") & ".xlsx"
      End If
   Next
   .Parent.AutoFilter.ShowAllData
End With

End Sub

[nankw83]

Hi Bevg,

The issue you're getting is the data in question is in column B but the code is looking at the data in column A. To illustrate, [B4].CurrentRegion is like selecting the cell B4 then pressing Ctrl+Shift+* so it selects the range A4:E16 based on your sample file which is stored in array b. Then when you're looping through the array, you're using a(x,1) which is looping through each row a(x,1) in column 1 a(x,1) of your 2d array. Therefore, to correct your issue you just need to change a(x,1) to a(x,2) to look at the values in the 2nd column

The length of the values in column B makes no difference

Hope that clears up the concept for you

[Bevg]

[SOLVED]Thank you again for the explanation. I've learned a lot from this post.

I changed [B4] but did not change the a(x,1).

I'm never going to forget this looping code.

[nankw83]

Glad I was able to help

Please take a moment & mark the thread as [SOLVED] from the Thread Tools above your first post