Split each row into individual files

[y3tter]

I have a very large table that includes thousands of rows. Row 1 is the header and I'd like to extrapolate each subsequent row to its own file, keeping the original header, and save each using the entry in column A. Could someone help me with a script to accomplish this?



Original table that has many entries, but reduced to two for illustrative purposes

Name	Number	Let	En	TM	Z	Y	1	2
Jane Doe	12345	LL	HG49	X X TM	36	42	42	42
Jake Wilson	67891	BB	dLL	YX32 47	42	42	42	0

<tbody>
</tbody>

File saved as "Jane Doe.xlsx"

Name	Number	Let	En	TM	Z	Y	1	2
Jane Doe	12345	LL	HG49	X X TM	36	42	42	42

<tbody>
</tbody>

File saved as "Jake Wilson.xlsx"

Name	Number	Let	En	TM	Z	Y	1	2
Jake Wilson	67891	BB	dLL	YX32 47	42	42	42	0

<tbody>
</tbody>

 

[Jambi46n2]

Try this..

Don't forget to update the Save Location in the Code from "C:" to the desired path.

Sub Split_By_Column_A()

If MsgBox("Create a New Workbook For Each Unique Value in Column A?", vbYesNo) = vbNo Then Exit Sub

Application.ScreenUpdating = False

'Create a New Sheet For Each Unique Value in Column A
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
'Column Number be split
vcol = 1
'Code to be applied to first sheet
Set ws = Sheets(1)
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
'Range of Title Headers
Title = "A1:XFD1"
titlerow = ws.Range(Title).Cells(1).Row
icol = ws.Columns.Count
'Cells in Columns Placed into Unique Workheet
ws.Cells(1, icol) = "Unique"
'For Loop ---> All Values in Column 1
For i = 1 To lr
On Error Resume Next
'All data in Active Worksheet are split into Multiple Worksheets by Column Value and Row
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))
'Clear Temp Data
ws.Columns(icol).Clear
'For Loop UBound ---> Returning the highest subscript in the array. The Upper Bound of the array.
For i = 1 To UBound(myarr)
ws.Range(Title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
'Evaluate Data with ISREF If Isn't a True/False Result in A1
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

'Split Sheets into Workbooks
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "[COLOR=#0000ff]C:\[/COLOR]" & xWs.Name & ".xlsx" '<----- Replace C:\ with Save Location
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox ("Completed! Please Verify Data Pulled Correctly.")
End Sub

 

[DanteAmor]

Hi @y3tter ,

If there is only one record per name, try this:

Sub Split_each_row()
  Dim sh As Worksheet, c As Range, wb As Workbook
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
    Set wb = Workbooks.Add
    sh.Range("1:1," & c.Row & ":" & c.Row).Copy Range("A1")
    wb.SaveAs ThisWorkbook.Path & "\" & c.Value
    wb.Close False
  Next
  MsgBox "End"
End Sub

----------------------
If there are several records in the database by name, then try this:

Sub Split_each_row2()
  Dim sh As Worksheet, c As Range, ky As Variant, wb As Workbook, wPath As String, lr As Long
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = ActiveSheet
  wPath = ThisWorkbook.Path & "\"
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("A" & Rows.Count).End(xlUp).Row
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("A2:A" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 1, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.ShowAllData
End Sub

 

[y3tter]

Awesome, thank you!!

Try this..

Don't forget to update the Save Location in the Code from "C:" to the desired path.

Sub Split_By_Column_A()

If MsgBox("Create a New Workbook For Each Unique Value in Column A?", vbYesNo) = vbNo Then Exit Sub

Application.ScreenUpdating = False

'Create a New Sheet For Each Unique Value in Column A
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
'Column Number be split
vcol = 1
'Code to be applied to first sheet
Set ws = Sheets(1)
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
'Range of Title Headers
Title = "A1:XFD1"
titlerow = ws.Range(Title).Cells(1).Row
icol = ws.Columns.Count
'Cells in Columns Placed into Unique Workheet
ws.Cells(1, icol) = "Unique"
'For Loop ---> All Values in Column 1
For i = 1 To lr
On Error Resume Next
'All data in Active Worksheet are split into Multiple Worksheets by Column Value and Row
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))
'Clear Temp Data
ws.Columns(icol).Clear
'For Loop UBound ---> Returning the highest subscript in the array. The Upper Bound of the array.
For i = 1 To UBound(myarr)
ws.Range(Title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
'Evaluate Data with ISREF If Isn't a True/False Result in A1
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

'Split Sheets into Workbooks
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "[COLOR=#0000ff]C:\[/COLOR]" & xWs.Name & ".xlsx" '<----- Replace C:\ with Save Location
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox ("Completed! Please Verify Data Pulled Correctly.")
End Sub

 

[Jambi46n2]

Awesome, thank you!!

I'm glad it worked!