TOUGH:split file into separate workbooks (single row, plus group m

[intoit]

Hi,

I would like to split the data within a worksheet into separate workbooks,
whereby a unique workbook is created for each row that has data. I'm using
the vba code on this site: http://www.rondebruin.nl/copy5_3.htm which is
very useful, however, I need the code to not only copy the information for
each unique row into a unique workbook, but also copy the column means
associated with the group (which is reported in the last used row of the
worksheet). The size of the group will vary from time to time, so the code
couldn't specify within which row the group means will be reported.

Any ideas here? Thanks.

 

[Patrick Molloy]

something simple like this maybe?

Sub NewBooks()
Dim thisrow As Long
Dim lastrow As Long
Dim wb As Workbook
Dim wbws As Worksheet

lastrow = Range("A" & Cells.Count).End(xlUp).Row

With ActiveSheet
For thisrow = 1 To lastrow - 1
Set wb = Workbooks.Add()
Set wbws = wb.ActiveSheet
.Rows(thisrow).Copy
wbws.Rows(1).PasteSpecial xlPasteAll
.Rows(lastrow).Copy
wbws.Rows(2).PasteSpecial xlPasteAll
wb.SaveAs thisrow
wb.Close False
Next
End With
End Sub

 

[intoit]

Thanks, Patrick. Your suggested code certainly guided me a lot of the way.
For anyone interested, I've modified the code so that a folder is created
within which the newly created workbooks are saved based on each respective
newly created workbook C1 cell value (which happens to be the person's name,
in my case).

Sub NewBooks()

Dim thisrow As Long
Dim thislastrow As Long
Dim wb As Workbook
Dim wbws As Worksheet
Dim foldername As String
Dim myPath As String
Dim file_name As String

With Sheets("Data")
thislastrow = .Cells(65536, 27).End(xlUp).Row

'Fill in the path\folder where you want the new folder with the files
myPath = Application.ThisWorkbook.path

'Add a slash at the end if the user forget it
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

'Create folder for the new files
foldername = myPath & ("Individuals") & "\"
MkDir foldername

With ActiveSheet
For thisrow = 2 To thislastrow - 1
Set wb = Workbooks.Add()
Set wbws = wb.ActiveSheet
.Rows(thisrow).Copy
wbws.Rows(1).PasteSpecial xlPasteValues
.Rows(thislastrow).Copy
wbws.Rows(2).PasteSpecial xlPasteValues
file_name = wb.Sheets("Sheet1").Range("C1")
wb.SaveAs foldername & file_name
wb.Close False
Next
End With
End With

End Sub