Splitting a report into new workbooks - excel

Question

I have a report that lists financial data by employee. I want to use a macro so I can split the report up by name, and then that creates a separate workbook for each individual employee.
I have the below VBA codes, which work fine, but it only splits in by employee on the same report, by creating a new tab for each person in the existing report. I would like this to action the same, but for it to create a new workbook for each employee, instead of creating a new tab for each employee on the existing report.
What do I need to amend in order to achieve this?
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 would you like to filter by?", title:="Filter column", Default:="3", 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
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

Use Workbooks.Add
Option Explicit
Sub parse_data()
'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.
Const TITLE_ROW = 1
Dim wbOut As Workbook
Dim ws As Worksheet, wsOut As Worksheet
Dim iLastRow As Long, iRow As Long
Dim iFilterCol As Integer
Dim sPath As String
' get filter column nu,ber
iFilterCol = Application.InputBox( _
prompt:="Which column would you like to filter by?", _
title:="Filter column", Default:="3", Type:=1)
If iFilterCol < 1 Then
MsgBox iFilterCol & " not valid", vbCritical
Exit Sub
End If
Set ws = ActiveSheet
sPath = ThisWorkbook.Path & "\"
iLastRow = ws.Cells(ws.Rows.Count, iFilterCol).End(xlUp).Row
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
' get unique values using dictionary
For iRow = TITLE_ROW + 1 To iLastRow
key = Trim(ws.Cells(iRow, iFilterCol))
If Not dict.exists(key) Then
dict.Add key, iRow
End If
Next
' create separate workbooks
Application.ScreenUpdating = False
For Each key In dict
' apply filter
ws.Rows(TITLE_ROW).AutoFilter Field:=iFilterCol, Criteria1:=key
' create new workbook
Set wbOut = Workbooks.Add
Set wsOut = wbOut.Sheets(1)
wsOut.Name = key
ws.Range("A" & TITLE_ROW & ":A" & iLastRow).EntireRow.Copy wsOut.Range("A1")
wsOut.Columns.AutoFit
' save and close
wbOut.SaveAs (sPath & key & ".xlsx")
wbOut.Close False
Next
ws.Activate
ws.AutoFilterMode = False
Application.ScreenUpdating = True
MsgBox dict.Count & " workbooks created", vbInformation
End Sub