Solved

Split a worksheet into multiple files

Posted on 2013-11-08
5
340 Views
Last Modified: 2013-11-13
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,
0
Comment
Question by:marian68
  • 3
  • 2
5 Comments
 
LVL 12

Expert Comment

by:Harry Lee
ID: 39634942
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
 
LVL 12

Expert Comment

by:Harry Lee
ID: 39634989
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
 

Author Comment

by:marian68
ID: 39641498
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
 
LVL 12

Accepted Solution

by:
Harry Lee earned 500 total points
ID: 39642309
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
 

Author Closing Comment

by:marian68
ID: 39646083
It works.
Thank you very much and have a nice day
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now