Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Split a worksheet into multiple files

Posted on 2013-11-08
5
Medium Priority
?
442 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 2000 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

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

609 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