Split 1 file into many files - Macro Help Needed

[LACubsFan]

Excel 2010 -- Windows XP Pro SP3

History:
I work for a company with 120 locations, each location has a 3 digit letter code. Up until yesterday I would get this massive excel report and send it off to all of our locations that showed them their appointment show/no show rate. Anywho today I was told that starting next week each location should only be able to see their own information

Question:
Is there a way I can tell Excel to take this 1 file and split it up into 120 separate files named after the 3 digit letter code in column A and the current date? (OAN 4-7, BVO 4-7 etc...) and put it on a folder on my desktop?

I'm including a link picture of the file because a picture is worth 1000 words.

I appreciate any help that someone can give me.

http://www.flickr.com/photos/61520533@N04/5599067699/

or

http://www.flickr.com/photos/61520533@N04/5599067699/lightbox/

 

[daverunt]

matthewjapp - I know what i have posted could probably be done in a far neater way. Why don't you post your code on the forum so we can all benefit - that's what the forums for. We are all here to learn.

 

[Norie]

LACubsFan

Do you want to create these new workbooks from the data in one worksheet?

With the workbook names being the codes, eg OHN, OMU etc, in column A (plus date)?

This code should create a new workbook for each unique code in column A on a wokrsheet called Master (change as required).

It saves but doesn't close the workbooks in the same folder as the original file.

There isn't much error checking, I think you could probably get that from some of dave's code.

Oh, and you might not see everything that's happening.

Anyway here it is.

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 strNewWBName As String
Dim LastRow As Long
    
    Set wsData = Worksheets("Master") ' worksheet data is in, change to suit
    
    Set wsCrit = Worksheets.Add
    
    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
        
        strNewWBName = rngCrit & "-" & Format(Date, "ddmmmyyyy")
        
        wsData.Range("A1:N" & LastRow).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
               
        With wsNew.Range("N1").EntireColumn
            .ColumnWidth = 66
            .WrapText = True
        End With
        
        wsNew.Range("M1").EntireColumn.Hidden = True
        
        wsNew.Name = rngCrit
        
        wsNew.Copy
        
        Set wbNew = ActiveWorkbook
        
        wbNew.SaveAs ThisWorkbook.Path & "\" & strNewWBName
        
        ' optional - uncomment to close new workbooks
        
        '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

[/code]

 

[daverunt]

Norie - I do like that filtering code. It's a lot quicker too.

 

[Norie]

Still needs some error checking though.

 

[Krishnakumar]

Hi,

You may find this useful.