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,
marian68Asked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
Harry LeeConnect With a Mentor Commented:
Marian,

You are correct. What the macro does is first create one Sheet per unique name in the list. then it will move the data line by line onto their according new named sheet based on the name field. After the data is distributed to the according sheets, it will then change each sheet to table. Finally, it will save each sheet as a file.

I just tested the code with the dummy data I have created and it works just fine.

Please take a look at my upload file and test the macro out.

Just wondering if the names in your list has punctuation marks or something in them that cause the macro to fail.

Can you upload some dummy data for me? All I need is the name column being the real thing. The rest of the data can be just "Data". I don't need to know what they are. You can even change the column headers to whatever, or simply like your sample on the question, "Field1", "Field2", "Field3"......so on.

I want to check if anything in the name list cause the problem.

BTW, which version of Excel are you using? I wonder if the problem has anything to do with the Excel version.
SplitFile-Test.xlsb
0
 
Harry LeeCommented:
Marian,

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.

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 & "\"
WBName = Left(Application.ActiveWorkbook.Name, Len(Application.ActiveWorkbook.Name) - 5)
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
    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 Sub

Open in new window

0
 
Harry LeeCommented:
Marian,

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 Sub

Open in new window

0
 
marian68Author Commented:
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,
0
 
marian68Author Commented:
It works.
Thank you very much and have a nice day
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.