Macro needed to convert row to sheets - vba

Question

I'm searching for a macro to take an excel file of several rows and split the sheet's rows up into sheets of any amount of rows we desire per-sheet, including the original rows, which should also be copied to each sheet.
In simple if i have a file with row
1
2
3
then that macro split the rows make a sheet with .csv file like these so we get a 3 file form above
file1 file2 file3
1 1 1
2 2
3
i hope you get the point
i searched for it but only able to find
Option Explicit
Sub SplitWorkbooksByNrows()
'Jerry Beaucaire, 2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range
srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string
'determine how many rows per sheet to create
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub 'exit if user clicks CANCEL
'Examples of usable ranges: A:A A:Z C:E F:F
Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL
'prompt to repeat row1 titles on each created sheet
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False 'turn off system alert messages, use default answers
fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH
Do While Len(fNAME) > 0 'exit loop when no more files found
Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file
With ActiveSheet
LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data?
If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
Cnt = Cnt + 1 'increment the sheet creation counter
Sheets.Add 'create the new sheet
If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles
'copy N rows of data to new sheet
Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
ActiveSheet.Columns.AutoFit 'cleanup
ActiveSheet.Move 'move created sheet to new workbook
'save with incremented filename in the destPATH
ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
ActiveWorkbook.Close False 'close the created workbook
Next rw 'repeat with next set of rows
End With
wbDATA.Close False 'close source data workbook
fNAME = Dir 'get next filename from the srcPATH
Loop 'repeat for each found file
Application.ScreenUpdating = True 'return to normal speed
MsgBox "A total of " & Cnt & " data files were created." 'report
End Sub
Reference https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows
What this macro is doing
if we have these rows
1
2
3
Macro doing this
file1 file2 file3
1 2 3
The code which is provided do exactly what i wanted but only if the macro can add the rows to. Like this.
file1 file2 file3
1 1 1
2 2
3

Answer 1

This may help get you started. You'll need to put your own range references and filepaths etc.
Sub SplitAndSave()
Dim rows As Long, rw As Long, myFolder As String, ws As Worksheet
rows = Worksheets("Sheet1").Range("A1:A10").rows.Count
myFolder = "C:\Users\Desktop\MyFolder\"
Set ws = Worksheets("Sheet2")
For rw = 1 To rows
ws.Cells.ClearContents
Range("A1:A" & rw).Copy Destination:=ws.Range("A1")
ws.SaveAs myFolder & "file" & rw & ".csv", xlCSV
Next rw
End Sub
This will split your data in Range(A1:A10) in to ten separate .csv files and place them in a folder called MyFolder on the desktop.