Excel worksheet splitting into multiple worksheets with folder save

Hello All,

I have a decent attempt at some code that I was able to glean from a forum or two but I am having a memory issues due to the size of my population. Essentially what I need to do, is take one large worksheet and split it to many worksheets (while keeping the same format for the header row) based on unique variables found in a name field (about 150 unique variables). This code works great but then bombs due to insufficient resources at around the 10th worksheet.

Rather than continue creating worksheets out to 150 (which I lack enough memory for anyway), I'm thinking the best bet would be to create & populate the new sheet for a unique variable, save that newly created sheet to a folder on my C Drive (which will be needed for a mail merge), delete the contents of the sheet in the macro file but not delete the sheet itself (as I think the code looks for that name before moving on), and then let the loop continue to run.

By the time I am finished, I should have around 1 base data table, 150 empty "named" worksheets, and 150 populated saved files on my hard drive.

The code I have now lacks:

1. Retention of header row formatting
2. The sheet saving and subsequent contents clearing procedure

Finally, sample spreadsheet is attached. The forums assistance is very much appreciated as I have literally been beating my head against this wall for about 5 hours.

Thank you in advance!

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, f As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 5
Set ws = Sheets("sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:I1"
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
End Sub