[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Split a worksheet into multiple files

Posted on 2013-11-08
5
Medium Priority
?
451 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 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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say 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

Microsoft's Excel has many features that most people will never need nor take advantage of.  Conditional formatting is one feature that you may find a necessity once you start using it.
Windows Explorer lets you open cabinet (cab) files like any other folder. In VBA you can easily handle normal files and folders, but opening and indeed creating cabinet files takes a lot more - and that's you'll find here.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
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.

873 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