Excel VBA - Copy Rows to New Workbook

Question

I have a macro written that will filter based on the values in a column, create a new worksheet named by the filter for each distinct value, then copy the rows containing that distinct value over to the new sheet. I know how to copy an entire worksheet into a new workbook (and name the workbook based on the name of the source worksheet), but I would like to cut out the middle step and just directly create new workbooks because some of my data sets are so large that Excel can't handle the number of new worksheets. I've got my original code that creates new worksheets below, and what I'd like to know is how I can modify it so that it creates new workbooks and saves them into the same directory as the original master file instead

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''This macro splits data into multiple worksheets based on the variables on a column found in Excel.''''
'''''An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.'''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column number would you like to filter by?", title:="Filter column", Default:="2", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''This section filters the data in the specified column, then copies it into a new worksheet''''''''''''
'''''The new worksheet is named after the filtered value'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True

End Sub

Answer 1

I kept playing around with it last night and came up with a solution that worked. It may not be the most elegant solution, but it got the job done in a reasonable amount of time. In the bottom section I moved the copy function inside the for loop, so now the code looks like this:

Sub Split_to_Workbooks()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Long
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Long
    Dim FPath As String

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''This macro splits data into multiple workbooks based on the variables in a column found in Excel.''''''
'''''An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.'''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = False
    FPath = Application.ActiveWorkbook.Path
    vcol = Application.InputBox(prompt:="Which column number would you like to filter by?", title:="Filter column", Default:="2", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''This section filters the data in the specified column, then copies it into a new workbook''''''''''''
'''''The new workbook is named after the filtered value'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Dim NewBook As Workbook
            Workbooks.Add.SaveAs Filename:=FPath & "\" & myarr(i) & "" & ".xlsx"
            Set NewBook = ActiveWorkbook
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy NewBook.Sheets(1).Range("A1")
            NewBook.Save
            NewBook.Close False
        Else

        End If
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True

End Sub