Solved

Split an worksheet into multiple files

Posted on 2013-11-08
6
264 Views
Last Modified: 2013-11-08
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.
Thank you very much,
0
Comment
Question by:marian68
  • 2
  • 2
  • 2
6 Comments
 
LVL 43

Accepted Solution

by:
Saqib Husain, Syed earned 300 total points
ID: 39633413
Sub split2sheets()
    Dim sws As Worksheet
    Dim tws As Worksheet
    Dim i As Long
    Dim rstrt As Long
    Dim rend As Long
    Set sws = ActiveSheet
    rstrt = 2
    For i = 3 To sws.Range("B" & Rows.Count).End(xlUp).Row + 1
        If sws.Cells(i, 2) <> sws.Cells(i - 1, 2) Then
            Set tws = Worksheets.Add
            tws.Name = sws.Cells(rstrt, 2)
            sws.Range("A1").EntireRow.Copy tws.Range("A1")
            sws.Range(sws.Cells(rstrt, 1), sws.Cells(i - 1, 1)).EntireRow.Copy tws.Range("A2")
            tws.Move
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs sws.Parent.Path & "\" & ActiveSheet.Name & ".xls"
            Application.DisplayAlerts = True
            ActiveWorkbook.Close
            rstrt = i
        End If
    Next i
End Sub
0
 
LVL 35

Assisted Solution

by:[ fanpages ]
[ fanpages ] earned 200 total points
ID: 39633415
Hi,

The code provided by ssaqibh in your earlier question, could be changed slightly thus:

Sub split2workbooks()
    
' See also: [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28288113.html#a39632141 ]

  Dim i                                                 As Long
  Dim lngApplication_SheetsInNewWorkbook                As Long
  Dim objWorkbook                                       As Workbook
  Dim rend                                              As Long
  Dim rstrt                                             As Long
  Dim sws                                               As Worksheet
  Dim tws                                               As Worksheet
  
  lngApplication_SheetsInNewWorkbook = Application.SheetsInNewWorkbook
  Application.SheetsInNewWorkbook = 1&
    
  Set sws = ActiveSheet
  
  rstrt = 2
  
  For i = 3 To sws.Range("B" & Rows.Count).End(xlUp).Row + 1
      
      If sws.Cells(i, 2) <> sws.Cells(i - 1, 2) Then
         Set objWorkbook = Workbooks.Add
         Set tws = objWorkbook.Worksheets(1&)
           
         tws.Name = Left$(sws.Cells(rstrt, 2), 31)
         sws.Range("A1").EntireRow.Copy tws.Range("A1")
         sws.Range(sws.Cells(rstrt, 1), sws.Cells(i - 1, 1)).EntireRow.Copy tws.Range("A2")
         
         rstrt = i
           
         Application.DisplayAlerts = False
           
         objWorkbook.Close SaveChanges:=True, _
                           Filename:="C:\" & tws.Name
                             
         Application.DisplayAlerts = True
      End If
      
  Next i
    
  Application.SheetsInNewWorkbook = lngApplication_SheetsInNewWorkbook

  Set objWorkbook = Nothing
  
End Sub

Open in new window



Please change this line to reference the required folder where the individual workbooks should be saved:

         objWorkbook.Close SaveChanges:=True, _
                           Filename:="C:\" & tws.Name

Presently they are saved in the root folder of drive C:

BFN,

fp.
Q-28289006.xls
0
 
LVL 35

Expert Comment

by:[ fanpages ]
ID: 39633417
^ Twenty four seconds! :)
0
ScreenConnect 6.0 Free Trial

Want empowering updates? You're in the right place! Discover new features in ScreenConnect 6.0, based on partner feedback, to keep you business operating smoothly and optimally (the way it should be). Explore all of the extras and enhancements for yourself!

 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 39633460
Cost of perfection with the extra comments and instructions.
0
 

Author Closing Comment

by:marian68
ID: 39633668
The both solution are excellent. For me the difference in speed is not noticeable.
Anyway the solution of ssaqibh doesn't need a path and suits me better.
Thank you both and have a nice day
0
 

Author Comment

by:marian68
ID: 39633693
I don't know if there is a point to ask another question.
It is possible to improve this code so that the data in each created file is organized as a table?
Let me know please if the answer is no or yes to ask another question
Thank you
0

Featured Post

3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

Question has a verified solution.

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

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

822 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