Split each row into individual files

Y

y3tter

Board Regular
Joined
Nov 11, 2012
Messages
147
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
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Number[/TD]
[TD]Let[/TD]
[TD]En[/TD]
[TD]TM[/TD]
[TD]Z[/TD]
[TD]Y[/TD]
[TD]1[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Jane Doe[/TD]
[TD]12345[/TD]
[TD]LL[/TD]
[TD]HG49[/TD]
[TD]X X TM[/TD]
[TD]36[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]42[/TD]
[/TR]
[TR]
[TD]Jake Wilson[/TD]
[TD]67891[/TD]
[TD]BB[/TD]
[TD]dLL[/TD]
[TD]YX32 47[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]










File saved as "Jane Doe.xlsx"
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Number[/TD]
[TD]Let[/TD]
[TD]En[/TD]
[TD]TM[/TD]
[TD]Z[/TD]
[TD]Y[/TD]
[TD]1[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Jane Doe[/TD]
[TD]12345[/TD]
[TD]LL[/TD]
[TD]HG49[/TD]
[TD]X X TM[/TD]
[TD]36[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]42[/TD]
[/TR]
</tbody>[/TABLE]





File saved as "Jake Wilson.xlsx"
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Number[/TD]
[TD]Let[/TD]
[TD]En[/TD]
[TD]TM[/TD]
[TD]Z[/TD]
[TD]Y[/TD]
[TD]1[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Jake Wilson[/TD]
[TD]67891[/TD]
[TD]BB[/TD]
[TD]dLL[/TD]
[TD]YX32 47[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]42[/TD]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
Try this..

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

Code: 
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
 
Last edited:
Upvote 0
Hi @y3tter ,

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

Code: 
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:

Code: 
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
 
Upvote 0
Awesome, thank you!!

Jambi46n2 said:
Try this..

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

Code: 
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
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Using ADODB way t populate data under header from file to another
Replies
0
Views
54
abdo meghari
A
D
  • Question Question
Copy/Pasting rows of a table to specific cells of a separate worksheet template and exporting as a new file.
Replies
0
Views
206
DjentChicken
D
P
  • Solved
Dynamic Subtotal of column after each row entry has been multiplied by two-way lookup
Replies
4
Views
265
KRice
K
N
  • Solved
VBA auto fill in information from the list in one sheet to another sheet and save as the excel file.
Replies
5
Views
191
ngochien251088
N
Cliffork
  • Solved
Print to PDF Macro, or possibly more
2 3
Replies
21
Views
228
mumps
mumps

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top