Split 1 file into many files - Macro Help Needed

L

LACubsFan

New Member
Joined
Apr 7, 2011
Messages
16
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 :roll:

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/
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
Not too big a problem, my idea will need some refining though:
A macro is required that
1. sets up a filter
2. filters the original sheet for each value in A:A
3. Copies the filtered sheet to a new workbook & stores under the value name

I don't know if yu know anything about macros
 
Upvote 0
Hi,

Incomplete but here's some code that will name the file with the first 3 letters.

I haven't figured out how to add the date yet as '& Date' adds 08\04\2011 in backslash format which is seen as part of the path.

Would anyone care to fix this?

Code: 
Sub Split_File()
 
'Set the Range
    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    RowNum = 1
 
        For Each Dn In Rng
 
        CopyRow = Dn.Row
'Finds last filled column
        lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
 
'Selects row across to last column
        ActiveSheet.Range("A" & RowNum, ActiveSheet.Cells(CopyRow, lastCol)).Select
        Selection.Copy
 
Path = "C:\"   ' To be corrected by you
 
strNewWBName = Path & Range("A" & RowNum).Value & ".xlsx"
Workbooks.Add
Sheets("Sheet1").Range("A1").Activate
Selection.PasteSpecial
ActiveWorkbook.SaveAs strNewWBName
ActiveWorkbook.Close
 
RowNum = RowNum + 1
Next
End Sub
 
Upvote 0
It will need to have some filter code added so files aren't reproduced for every same 3 digit code in A. I'm not sure how to go about that yet.

Date Sorted:

Don't forget to put in your path.
Make sure it ends with a Backslash.

e.g
Path = "C:\Documents and Settings\User Name\Desktop\Junk\"

Code: 
strNewWBName = Path & Range("A" & RowNum).Value & " " & Format$(Date, "mm-dd-yyyy") & ".xlsx"
 
Last edited:
Upvote 0
Not the best method of doing this I'm sure.
The macro needs to go in the file being split.

A file is created for the 3 letters in A with date. The row is pasted in.
The next row is checked. If the filename already exists it is opened and the next row pasted in. The file is then close saving changes. If not it creates a new file.

It may take some time to complete because of opening closing, saving files.

Code: 
Sub Split_File()
 
'Set the Range
    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
 
    RowNum = 1
 
    For Each Dn In Rng
 
    CopyRow = Dn.Row
 
'Finds last filled column
    lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
 
'Selects row across to last column
    ActiveSheet.Range("A" & RowNum, ActiveSheet.Cells(CopyRow, lastCol)).Select
    Selection.Copy
 
    Path = "C:\Documents and Settings\User Name\Desktop\Junk\"
 
    strNewWBName = Path & Range("A" & RowNum).Value & " " & Format$(Date, "mm-dd-yyyy") & ".xlsx"
 
If Len(Dir(strNewWBName)) > 0 Then
    Workbooks.Open (strNewWBName)
    Sheets("Sheet1").Range("A1").Activate
 
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
 
    Selection.PasteSpecial
 
  Else
  Workbooks.Add
    Sheets("Sheet1").Range("A1").Activate
    Selection.PasteSpecial
    ActiveWorkbook.SaveAs strNewWBName
 
End If
 
RowNum = RowNum + 1
ActiveWorkbook.Close SaveChanges:=True
 
    Next
    End Sub
 
Last edited:
Upvote 0
A little bit quicker - opens the files and keeps them open until the end.
Checks to see if they are open before pasting new rows.

That's me done!

Code: 
Sub Split_File_Two()
 
'Set the Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
RowNum = 1
For Each Dn In Rng
 
ThisWorkbook.Activate
 
CopyRow = Dn.Row
 
'Finds last filled column
lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
 
'Selects row across to last column
ActiveSheet.Range("A" & RowNum, ActiveSheet.Cells(CopyRow, lastCol)).Select
 
Selection.Copy
 
Path = "C:\Junk\"
 
strNewWBName = Path & Range("A" & RowNum).Value & " " & Format$(Date, "mm-dd-yyyy") & ".xlsx"
 
'Checks to see if file present
If Len(Dir(strNewWBName)) > 0 Then
If IsFileOpen(strNewWBName) Then GoTo Line1
Workbooks.Open (strNewWBName)
Line1:
SourceFile = Dir(strNewWBName)
Windows(SourceFile).Activate
Sheets("Sheet1").Range("A1").Activate
 
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
 
Selection.PasteSpecial
Else
Workbooks.Add
Sheets("Sheet1").Range("A1").Activate
Selection.PasteSpecial
ActiveWorkbook.SaveAs strNewWBName
 
End If
RowNum = RowNum + 1
Next
 
For Each WB In Workbooks
If Not WB.Name = ThisWorkbook.Name Then
WB.Close SaveChanges:=True
End If
Next WB
MsgBox ("Finished")
End Sub
 
 
'http://support.microsoft.com/kb/291295
    Function IsFileOpen(filename)
        Dim filenum As Integer, errnum As Integer
        On Error Resume Next   ' Turn error checking off.
        filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
        Open filename For Input Lock Read As #filenum
        Close filenum          ' Close the file.
     errnum = Err           ' Save the error number that occurred.
     On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
     Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
        ' Another error occurred.
        Case Else
            Error errnum
    End Select
End Function
 
Upvote 0
daverunt said:
Not the best method of doing this I'm sure.
The macro needs to go in the file being split.

A file is created for the 3 letters in A with date. The row is pasted in.
The next row is checked. If the filename already exists it is opened and the next row pasted in. The file is then close saving changes. If not it creates a new file.

It may take some time to complete because of opening closing, saving files.

Code: 
Sub Split_File()
 
'Set the Range
    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
 
    RowNum = 1
 
    For Each Dn In Rng
 
    CopyRow = Dn.Row
 
'Finds last filled column
    lastCol = ActiveSheet.Range("A1").End(xlToRight).Column
 
'Selects row across to last column
    ActiveSheet.Range("A" & RowNum, ActiveSheet.Cells(CopyRow, lastCol)).Select
    Selection.Copy
 
    Path = "C:\Documents and Settings\User Name\Desktop\Junk\"
 
    strNewWBName = Path & Range("A" & RowNum).Value & " " & Format$(Date, "mm-dd-yyyy") & ".xlsx"
 
If Len(Dir(strNewWBName)) > 0 Then
    Workbooks.Open (strNewWBName)
    Sheets("Sheet1").Range("A1").Activate
 
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
 
    Selection.PasteSpecial
 
  Else
  Workbooks.Add
    Sheets("Sheet1").Range("A1").Activate
    Selection.PasteSpecial
    ActiveWorkbook.SaveAs strNewWBName
 
End If
 
RowNum = RowNum + 1
ActiveWorkbook.Close SaveChanges:=True
 
    Next
    End Sub
Click to expand...


Dave Runt -- WOW. Thank you so much for the time it took you to do this. I like this version the best because I can kinda watch while it does it's thing, there is just 1 big thing, and 3 little things that I'm hoping you can tweak to make this work 100%.

1) Headers -- Can you make row 1 with the headers be a constant thing on all of the new files excel creates? Right now it detects row 1 as just another location and it gets its own file.

little things 1,2,3 -- Can you set the macro to hide column M, set column N width at 66, and make column N wrap text? (If not possible, I'll live)

Again thanks so much, what I don't know about VBA could fill the grand canyon.
 
Upvote 0
Hi,

this should take care of the headers part.
I have ammended the code to copy from A2 onward of the sheet to split, to A2 of each new workbook.
At the end of creating the files it will go through all open workbooks and append the header row to A1 before closing them.

I won't have time over the next 3 days to look at the other items but you can always post another thread for that.

Code: 
Sub Split_File_Three()
 
'Set the Range
    Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 
    RowNum = 2
    For Each Dn In Rng
 
ThisWorkbook.Activate
    CopyRow = Dn.Row
 
'Finds last filled column
        lastCol = ActiveSheet.Range("A2").End(xlToRight).Column
 
'Selects row across to last column
        ActiveSheet.Range("A" & RowNum, ActiveSheet.Cells(CopyRow, lastCol)).Select
 
        Selection.Copy
 
    Path = "C:\Junk\"
    strNewWBName = Path & Range("A" & RowNum).Value & " " & Format$(Date, "mm-dd-yyyy") & ".xlsx"
 
'Checks to see if file present
    If Len(Dir(strNewWBName)) > 0 Then
    If IsFileOpen(strNewWBName) Then GoTo Line1
       Workbooks.Open (strNewWBName)
Line1:
SourceFile = Dir(strNewWBName)
Windows(SourceFile).Activate
        Sheets("Sheet1").Range("A2").Activate
 
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
 
    Selection.PasteSpecial
  Else
    Workbooks.Add
    Sheets("Sheet1").Range("A2").Activate
    Selection.PasteSpecial
 
    ActiveWorkbook.SaveAs strNewWBName
 
 
End If
RowNum = RowNum + 1
Next
 
For Each WB In Workbooks
ThisWorkbook.Activate
Range("A1", ActiveSheet.Cells(1, lastCol)).Select
Selection.Copy
WB.Activate
Sheets("Sheet1").Range("A1").Activate
Selection.PasteSpecial
 
    If Not WB.Name = ThisWorkbook.Name Then
       WB.Close SaveChanges:=True
       End If
       Next WB
   MsgBox ("Finished")
    End Sub
 
'http://support.microsoft.com/kb/291295
    Function IsFileOpen(filename)
        Dim filenum As Integer, errnum As Integer
        On Error Resume Next   ' Turn error checking off.
        filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
        Open filename For Input Lock Read As #filenum
        Close filenum          ' Close the file.
     errnum = Err           ' Save the error number that occurred.
     On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
     Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
        ' Another error occurred.
        Case Else
            Error errnum
    End Select
End Function
 
Upvote 0
LACLUBSMAN - there is a far better and easier way to achieve what you're trying to do - mailme privately and I'll communicate over my work e-mail address, you'll like the solution...
 
Upvote 0
Probably better to copy just once

Code: 
Next
ThisWorkbook.Activate
Range("A1", ActiveSheet.Cells(1, lastCol)).Select
Selection.Copy
        
For Each WB In Workbooks
WB.Activate
Sheets("Sheet1").Range("A1").Activate
Selection.PasteSpecial
 
    If Not WB.Name = ThisWorkbook.Name Then
       WB.Close SaveChanges:=True
       End If
       Next WB
   MsgBox ("Finished")
    End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
S
  • Question Question
Need help on Insert PDF file VBA function
Replies
3
Views
521
Micron
M
D
  • Solved
Adding images in table with formatting into Outlook using a file picker
Replies
1
Views
2K
DeMoNloK
D
A
  • Question Question
Page break issues when exporting to pdf from userform (VBA)
Replies
0
Views
894
auglocqnuk
A
S
  • Question Question
Excel 2013 repairing macro enabled file HELP
Replies
0
Views
1K
sibley14
S

Forum statistics

Threads
1,224,551
Messages
6,179,473
Members
452,915
Latest member
hannnahheileen

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top