Solved

Burst a single Excel worksheet into multiple new Excel files

Posted on 2010-11-11
21
1,123 Views
Last Modified: 2012-05-10
Windows XP, Excel 2007, Novice user and VB experience

I have a workbook that has multiple worksheets(Sheet1,Sheet2,Sheet3...).  Sheet1 of the workbook has mutiple columns and two of those columns are gl entity and facility.  Below is a small sample of the data on Sheet1, not including all the other columns for the sake of simplicity.

row#01 gl entity   facility name
row#02 102      Fannin Regional Hospital
row#03 102      Fannin Regional Hospital
row#04 102      Fannin Regional Hospital
row#05 104      Weatherford Regional Medical Center
row#06 104      Weatherford Regional Medical Center
row#07 112      Parkway Regional Hospital
row#08 112      Parkway Regional Hospital
row#09 112      Parkway Regional Hospital
row#10 112      Parkway Regional Hospital

My question is how can the all of the information on Sheet1 be written to seperate individual new Excel files where each file contains only records for each gl entity and also the contain line row #1 that is the column headers?  The data on Sheet1 is sorted by the gl entity.  

Desired results in new Excel file #1, desired filename c:\work\102.xls.
gl entity      facility
102      Fannin Regional Hospital
102      Fannin Regional Hospital
102      Fannin Regional Hospital

Desired results in new Excel file #2, desired filename c:\work\104.xls.
gl entity      facility
104      Weatherford Regional Medical Center
104      Weatherford Regional Medical Center
104      Weatherford Regional Medical Center
104      Weatherford Regional Medical Center

Desired results in new Excel file #3, desired filename c:\work\112.xls.
gl entity      facility
112      Parkway Regional Hospital
112      Parkway Regional Hospital
112      Parkway Regional Hospital
112      Parkway Regional Hospital

Thanks in advance
Misty
0
Comment
Question by:mreid3847
  • 7
  • 7
  • 5
  • +2
21 Comments
 
LVL 37

Expert Comment

by:TommySzalapski
ID: 34117888
Try this. Feel free to change the .xls to .xlsx. I always use the old format when I can for backward compatibility.
Put the code in the Sheet1 object (I set it like it was attached to a button, but you can do whatever)
Private Sub CommandButton1_Click()
Dim i, lastRow, nextRow, numNames As Integer
Dim bookName As String
Dim bookNames() As String
Dim xlBook As Workbook

numNames = 0

lastRow = Sheet1.UsedRange.Rows.Count

For i = 2 To lastRow
  bookName = Cells(i, 1).Text & ".xls"
  On Error Resume Next
  If Workbooks(bookName).Name = ":" Then  ' ":" is not allowed in name so will never be true
    On Error GoTo 0
    Set xlBook = Workbooks.Add
    Sheet1.Rows(1).Copy xlBook.Sheets(1).Rows(1)
    xlBook.SaveAs bookName
    numNames = numNames + 1
    ReDim Preserve bookNames(1 To numNames)
    bookNames(numNames) = bookName
  End If
  On Error GoTo 0
  
  nextRow = Workbooks(bookName).Sheets(1).UsedRange.Rows.Count + 1
  Sheet1.Rows(i).Copy Workbooks(bookName).Sheets(1).Rows(nextRow)
Next

For i = 1 To numNames
  Workbooks(bookNames(i)).Save
  Workbooks(bookNames(i)).Close
Next
End Sub

Open in new window

0
 
LVL 23

Expert Comment

by:Michael74
ID: 34118040
Try this code

Just place it into a new module
Sub copy()
   Dim names As Object, count As Object
   Dim newWB As Workbook
   Dim i As Long
   Dim k As Variant
   Dim header1 As String, header2 As String
   
   Set names = CreateObject("Scripting.Dictionary")
   Set count = CreateObject("Scripting.Dictionary")
   
   For i = 2 To Cells(Rows.count, "A").End(xlUp).Row
      If Not names.Exists(Range("A" & i).Value) Then
         names.Add Range("A" & i).Value, Range("B" & i).Value
         count.Add Range("A" & i).Value, 1
      Else
         count.Item(Range("A" & i).Value) = count.Item(Range("A" & i).Value) + 1
      End If
   Next
   
   header1 = Range("A1").Value
   header2 = Range("B1").Value
   
   For Each k In names.Keys
      Set newWB = Workbooks.Add
      newWB.Sheets("Sheet1").Name = k
      Application.DisplayAlerts = False
      newWB.Sheets("Sheet2").Delete
      newWB.Sheets("Sheet3").Delete
      Application.DisplayAlerts = True
      newWB.Sheets(1).Range("A1").Value = header1
      newWB.Sheets(1).Range("B1").Value = header2
      For i = 2 To count.Item(k) + 1
         newWB.Sheets(1).Range("A" & i).Value = k
         newWB.Sheets(1).Range("A" & i).Value = names.Item(k)
      Next
      newWB.Sheets(1).Range("A1:B1").Font.Bold = True
      newWB.Sheets(1).Range("A:A").EntireColumn.AutoFit
      newWB.Sheets(1).Range("B:B").EntireColumn.AutoFit
      
      newWB.SaveAs ("c:\work\" & k & ".xls")
      newWB.Close False
      
   Next
   
End Sub

Open in new window

0
 

Author Comment

by:mreid3847
ID: 34119647
Tommy

I attempted to put the code in and then select it from the macro list. But it doesn't appear to run, generates no error.  No files are created again no error either.  Thanks.

Sub MakeManyFromOne()
    Dim i, lastRow, nextRow, numNames As Integer
    Dim bookName As String
    Dim bookNames() As String
    Dim xlBook As Workbook
 
    numNames = 0
 
    lastRow = Sheet1.UsedRange.Rows.Count
 
    For i = 2 To lastRow
    bookName = Cells(i, 1).Text & ".xls"
    On Error Resume Next
    If Workbooks(bookName).Name = ":" Then  ' ":" is not allowed in name so will never be true
        On Error GoTo 0
        Set xlBook = Workbooks.Add
        Sheet1.Rows(1).Copy xlBook.Sheets(1).Rows(1)
        xlBook.SaveAs bookName
        numNames = numNames + 1
        ReDim Preserve bookNames(1 To numNames)
        bookNames(numNames) = bookName
    End If
    On Error GoTo 0
   
    nextRow = Workbooks(bookName).Sheets(1).UsedRange.Rows.Count + 1
    Sheet1.Rows(i).Copy Workbooks(bookName).Sheets(1).Rows(nextRow)
    Next
 
    For i = 1 To numNames
    Workbooks(bookNames(i)).Save
    Workbooks(bookNames(i)).Close
    Next
End Sub
0
 

Author Comment

by:mreid3847
ID: 34119710
Michael

I am going to attempt your solution next.  I am very weak on VB and Excel in general.  But what I am picking up from your code is that for each column I have in the spreadsheet, there are really more than two, I would need to go in and add them, correct?

For the sake of a simple example I only documented a couple of the columns in my file.  I have attached a sample of my true data contained in Sheet1 only. sample.xls

Is it possible to make what you suggested a little more flexible so it will copy all of the columns weather I have 1 or 200?  Row#1 will always be the header.  And then each new file only needs the records per gl entity.

I appreciate the assistance.
0
 
LVL 37

Expert Comment

by:TommySzalapski
ID: 34120683
Try mine again. Which sheet has the actual data? I used your sample and it worked.
Is the data in column 1 on sheet 1?
Change the 1 to the column number of the column with the GL entities.
  bookName = Cells(i, 1).Text & ".xls"
Put the code in the code area for the sheet the data is in and remove all the Sheet1. things. Tell me how it goes.
I tested the code and it works well.
Dim i, lastRow, nextRow, numNames As Integer

Dim bookName As String

Dim bookNames() As String

Dim xlBook As Workbook



numNames = 0



lastRow = UsedRange.Rows.Count



For i = 2 To lastRow

  bookName = Cells(i, 1).Text & ".xls"

  On Error Resume Next

  If Workbooks(bookName).Name = ":" Then  ' ":" is not allowed in name so will never be true

    On Error GoTo 0

    Set xlBook = Workbooks.Add

    Rows(1).Copy xlBook.Sheets(1).Rows(1)

    xlBook.SaveAs bookName

    numNames = numNames + 1

    ReDim Preserve bookNames(1 To numNames)

    bookNames(numNames) = bookName

  End If

  On Error GoTo 0

  

  nextRow = Workbooks(bookName).Sheets(1).UsedRange.Rows.Count + 1

  Rows(i).Copy Workbooks(bookName).Sheets(1).Rows(nextRow)

Next



For i = 1 To numNames

  Workbooks(bookNames(i)).Save

  Workbooks(bookNames(i)).Close

Next

Open in new window

0
 

Author Comment

by:mreid3847
ID: 34120826
Good morning Tommy

Yes the data currently resides in Sheet1, and column 1 contains the information that would be used to group/select a range of records and all columns should of that said group be included in the new data file, along with the header.

I'm sorry but I am a little gray on what you mean by "Put the code in the code area for the sheet the data is in and remove all the Sheet1. things."
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34120969
Misty,

It would be useful to see some sample data and/or a sample file.  EE now allows you to directly upload files to your question.

Please be advised that once you upload a file, it can be publicly accessed, and that it may not be possible to fully and permanently delete it.  The file may also be indexed by the major search engines.

Therefore, be very careful about posting proprietary, confidential, or other sensitive information.  If necessary, [b]use "fake" and/or obfuscated data[/b] in your sample.

Please note that at present EE restricts uploads to certain file types.  If your file type does not match those in the list, you can use http://www.ee-stuff.com instead, which is not officially an EE site, but is run by people connected to EE.

Patrick
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34120987
Tommy,

>>Dim i, lastRow, nextRow, numNames As Integer

In that declaration, i, lastRow, and nextRow are actually getting dimensioned as Variant.  You have to specify the data type for each variable, or it will default to Variant.

Also, using Integer for anything tracking rows is an accident waiting to happen.  Once you hit Row 32768, your code will go boom.

:)

Patrick
0
 

Author Comment

by:mreid3847
ID: 34121027
Thanks Patrick for the information, that was really helpful and good to know and I will follow the helpful guides you suggested.

I did actually attached a small sample the data file previously, embedded? Which might not have been the best way to do so earlier in the post.  I am reattaching the sample data file now.


sample.xls
0
 
LVL 37

Expert Comment

by:TommySzalapski
ID: 34121140
With that in mind. This code should work fine. It actually saves and closes the workbooks after it makes them. If you want them to stay open remove the line
Workbooks(bookNames(i)).Close
Dim i As Long, lastRow As Long, nextRow As Long, numNames As Long

Dim bookName As String

Dim bookNames() As String

Dim xlBook As Workbook



numNames = 0



lastRow = Sheet1.UsedRange.Rows.Count



For i = 2 To lastRow

  bookName = Sheet1.Cells(i, 1).Text & ".xls"

  On Error Resume Next

  If Workbooks(bookName).Name = ":" Then  ' ":" is not allowed in name so will never be true

    On Error GoTo 0

    Set xlBook = Workbooks.Add

    Sheet1.Rows(1).Copy xlBook.Sheets(1).Rows(1)

    xlBook.SaveAs bookName

    numNames = numNames + 1

    ReDim Preserve bookNames(1 To numNames)

    bookNames(numNames) = bookName

  End If

  On Error GoTo 0

  

  nextRow = Workbooks(bookName).Sheets(1).UsedRange.Rows.Count + 1

  Sheet1.Rows(i).Copy Workbooks(bookName).Sheets(1).Rows(nextRow)

Next



For i = 1 To numNames

  Workbooks(bookNames(i)).Save

  Workbooks(bookNames(i)).Close

Next

Open in new window

0
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 

Author Comment

by:mreid3847
ID: 34121363
Tommy how do I run the code you supplied?

I opened my workbook that contains my data.  I copied the code you supplied into a module and saved it.  I then selected my macro option, in the list I see the new entry that I named SplitOneIntoMany, I select it and nothing happens.  No error, no files created.
0
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 350 total points
ID: 34121396
Misty,

I have not tried Tommy's code, but this appears to be working.  It automatically adjusts to the right number of rows and columns, and it does not require the data to be sorted beforehand.  It also asks you to specify what folder to save the output to.

It uses a Dictionary object to work its magic; for more info on Dictionaries please see my article on the subject

Just put the code below into a new module in your sample workbook.

Patrick
Option Explicit

Function GetDirectory2(Optional Msg As String = "Select Folder:") As String
    
    ' Use this version when you want to be able to create a new directory and
    ' have the function return that path
    
    Dim objShell As Object 'Shell32.Shell
    Dim objFolder As Object 'Shell32.Folder
    Dim objFolderItem As Object 'Shell32.FolderItem
    
    GetDirectory2 = ""
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, Msg, 0, 0)
    
    If (Not objFolder Is Nothing) Then
        Set objFolderItem = objFolder.Self
        If (Not objFolderItem Is Nothing) Then
            GetDirectory2 = objFolderItem.Path
        End If
    End If
    
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
    
End Function

Sub SplitUp()
    
    Dim dic As Object
    Dim LastR As Long, LastC As Long
    Dim SourceWs As Worksheet
    Dim DestWb As Workbook
    Dim DestWs As Worksheet
    Dim Counter As Long
    Dim Keys As Variant
    Dim arr As Variant
    Dim SaveToFolder As String
    Dim OldSheetsInNew As Long
    
    SaveToFolder = GetDirectory2("Select folder to save files to")
    If SaveToFolder = "" Then
        MsgBox "No folder selected", vbCritical, "Aborting"
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        OldSheetsInNew = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .DisplayAlerts = False
    End With
    
    Set SourceWs = ThisWorkbook.Worksheets("Sheet1")
    With SourceWs
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.[a2], .Cells(LastR, "a")).Value
    End With
    
    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        .CompareMode = vbTextCompare
        For Counter = 1 To UBound(arr, 1)
            .Item(arr(Counter, 1)) = arr(Counter, 1)
        Next
        Keys = .Keys
    End With
    
    With SourceWs
        .[a1].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlYes
        For Counter = 0 To UBound(Keys)
            .[a1].AutoFilter 1, Keys(Counter), xlAnd
            Set DestWb = Workbooks.Add
            Set DestWs = DestWb.Worksheets(1)
            .Range(.[a1], .Cells(LastR, LastC)).SpecialCells(xlCellTypeVisible).Copy DestWs.[a1]
            DestWs.Columns.AutoFit
            DestWb.SaveAs SaveToFolder & "\" & Keys(Counter) & ".xlsx", xlOpenXMLWorkbook
            DestWb.Close False
        Next
        .[a1].AutoFilter
    End With
    
    With Application
        .ScreenUpdating = True
        .SheetsInNewWorkbook = OldSheetsInNew
        .DisplayAlerts = True
    End With
    
    MsgBox "Done"
    
End Sub

Open in new window

0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34121423
BTW, for the sake of completeness, it would be helpful to add this line before End Sub:

Set dic = Nothing

Open in new window

0
 

Author Comment

by:mreid3847
ID: 34121526
Patrick

I applied the code you supplied.  I get a run time error '1004'.  Sort method of Range class failed.

and debug highlights line
    .[a1].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlYes
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34121604
That's very odd.  When I put the code into your sample workbook and run it, everything runs without incident.
0
 
LVL 37

Expert Comment

by:TommySzalapski
ID: 34121647
Yeah, when I put my code into your workbook it works too.
0
 
LVL 37

Assisted Solution

by:TommySzalapski
TommySzalapski earned 150 total points
ID: 34121678
Try this file. I added the code to a button. Click the button.
sample--2-.xls
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34121709
Misty,

If it still is not working, can you post an updated sample file that contains the code as you actually tried it?

Patrick
0
 
LVL 33

Expert Comment

by:Norie
ID: 34121970
Try this.

I'v attached the sample data file with the code in it as well.
Option Explicit



Sub DistributeRowsToNewWBS()

Dim wbNew As Workbook

Dim wsData As Worksheet

Dim wsCrit As Worksheet

Dim wsNew As Worksheet

Dim rngCrit As Range

Dim LastRow As Long

Dim LastCol As Long



    Set wsData = Worksheets("Sheet1")

    Set wsCrit = Worksheets.Add

    

    LastCol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column

    

    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row

    

    wsData.Range("A1:A" & LastRow).AdvancedFilter action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

    

    Set rngCrit = wsCrit.Range("A2")

    While rngCrit.Value <> ""

        Set wsNew = Worksheets.Add

        wsData.Range("A1:A" & LastRow).Resize(, LastCol).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True

        wsNew.Name = rngCrit

        wsNew.Copy

        Set wbNew = ActiveWorkbook

        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit

        wbNew.Close SaveChanges:=True

        Application.DisplayAlerts = False

        wsNew.Delete

        rngCrit.EntireRow.Delete

        Set rngCrit = wsCrit.Range("A2")

    Wend

    

    wsCrit.Delete

    Application.DisplayAlerts = True

End Sub

Open in new window

EE---12Nov2010---sample.xls
0
 

Author Closing Comment

by:mreid3847
ID: 34121979
Thanks to you both Patrick and Tommy.

I had to totally close Excel and come back in and then the code Patrick supplied did work without error.  And Tommy the last example you provided also worked.

The Dictionary object was very functional.  I've pulled the article that was also suggested and will read over it at another time as it seemed to be a well written article.

You guys just saved me hours of work and provided helpful coaching along the way.  I'm grateful for your assistance.

Misty
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 34122035
Misty,

Glad to help, and thanks also for the "helpful" vote on the article.

Patrick
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
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…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

707 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

11 Experts available now in Live!

Get 1:1 Help Now