marian68
asked on
Split a worksheet into multiple files
Hi guys,
I have a worksheet with about 15000 records organized in a table as follows;
Field1 Fiel 2 Field3 Field4 Field5 Field6
Data Name1 Data data data data
data Name1 data data data data
Data Name2 Data data data data
data Name2 data data data data
Can anyone give the VBA code to split the worksheet in multiple excel files = Number of Names.
For each Name in the Field 2 I would like to have a file. The number of records is different from one name to another. So a name can have 33 records and another name 333 records. The number of names is about 70 (I have just got the code for this).
In addition to this I would like if it is possible that the data in each newly created file to be exported and organized as a table.
Thank you very much,
I have a worksheet with about 15000 records organized in a table as follows;
Field1 Fiel 2 Field3 Field4 Field5 Field6
Data Name1 Data data data data
data Name1 data data data data
Data Name2 Data data data data
data Name2 data data data data
Can anyone give the VBA code to split the worksheet in multiple excel files = Number of Names.
For each Name in the Field 2 I would like to have a file. The number of records is different from one name to another. So a name can have 33 records and another name 333 records. The number of names is about 70 (I have just got the code for this).
In addition to this I would like if it is possible that the data in each newly created file to be exported and organized as a table.
Thank you very much,
Marian,
I have done some minor change to the code to make the output files tables.
I have done some minor change to the code to make the output files tables.
Function IsInArray(stringToBeFound As String, Arr As Variant) As Boolean
IsInArray = (UBound(Filter(Arr, stringToBeFound)) > -1)
End Function
Sub SplitFile()
Dim I1 As Long, I2 As Long, DoneArr() As Variant, WS As Worksheet, TgrRw As Long, NewWb As Workbook, ExportPath As String, ExportFName As String
Dim SheetName As String, WBName As String
Set SrcWS = ActiveSheet
Application.ScreenUpdating = False
ExportPath = Application.ActiveWorkbook.Path & "\"
If ThisWorkbook.FileFormat = 50 Or ThisWorkbook.FileFormat = 51 Or ThisWorkbook.FileFormat = 52 Then
WBName = Left(Application.ActiveWorkbook.Name, Len(Application.ActiveWorkbook.Name) - 5)
Else
WBName = Left(Application.ActiveWorkbook.Name, Len(Application.ActiveWorkbook.Name) - 4)
End If
I2 = 0
ReDim DoneArr(I2)
For I1 = 2 To SrcWS.Cells(Rows.Count, 2).End(xlUp).Row
If I1 = 2 Then
I2 = 1
ReDim Preserve DoneArr(I2)
DoneArr(I2) = SrcWS.Cells(I1, 2)
Else
If IsInArray(SrcWS.Cells(I1, 2), DoneArr) Then
Else
I2 = I2 + 1
ReDim Preserve DoneArr(I2)
DoneArr(I2) = SrcWS.Cells(I1, 2)
End If
End If
Next
For I1 = 1 To UBound(DoneArr)
Worksheets.Add.Name = DoneArr(I1)
Next
For Each WS In Worksheets
If WS.Name = SrcWS.Name Then
Else
SrcWS.Range("A1").EntireRow.Copy WS.Range("A1")
End If
Next
For I1 = 2 To SrcWS.Cells(Rows.Count, 2).End(xlUp).Row
For I2 = 1 To UBound(DoneArr)
Set WS = Sheets(DoneArr(I2))
If SrcWS.Cells(I1, 2) = DoneArr(I2) Then
TgrRw = WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
SrcWS.Cells(I1, 2).EntireRow.Copy WS.Range("A" & TgrRw)
WS.Columns.AutoFit
End If
Next
Next
For Each WS In Worksheets
If WS.Name = SrcWS.Name Then
Else
WS.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column)), , xlYes).Name = "Table1"
SheetName = WBName & "_" & WS.Name
Set NewWb = Workbooks.Add
WS.Move before:=NewWb.Sheets(1)
ExportFName = ExportPath & SheetName & ".xlsx"
NewWb.SaveAs Filename:=ExportFName
NewWb.Close
End If
Next
Application.ScreenUpdating = True
End SubASKER
Hi Harry,
Sorry for delay.
Your code doesn't work.
First it creates an worksheet for each name and not a file.
Second the data in each worksheet is not organized as a table.
Third thing to mention is that the execution of the macro stops at a name with a message concerning the content of the name. But the name is ok, all conditions are met.
Thank you,
Sorry for delay.
Your code doesn't work.
First it creates an worksheet for each name and not a file.
Second the data in each worksheet is not organized as a table.
Third thing to mention is that the execution of the macro stops at a name with a message concerning the content of the name. But the name is ok, all conditions are met.
Thank you,
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
It works.
Thank you very much and have a nice day
Thank you very much and have a nice day
I have written up the following code. Can you please make backup of your file and test this out?
Put everything in a new module in your file, or Personal macro Database and run it on the file you want to split.
Open in new window