Solved

Split a worksheet into multiple files

Posted on 2013-11-08
5
394 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 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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
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…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

749 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