Split a workbook into several using cell value for filenames

[kevinho]

Hi

First time poster and novice when it comes to Macro writing here so
please be gentle!...

What I need to do is as follows;

I have a workbook with 3 sheets, titled; "Prod" , "Die" , "Job"
Based on a value in a cell in "Prod"; eg A1: "P2380"I need to do the
following.

1. Create a new folder in a predetermined location named after the cell
value.

2. Split the workbook into 3 separate files in this new folder using
the naming convention CellValue_SheetName.xls;
-e.g.
P2380_Prod.xls
P2380_Die.xls
P2380_Job.xls-.

3. Close and Delete the original file.

I'm going to have a go at it, but my knowledge of VB is very
limited.....

thanks for any help you can give

Kev

 

[Dave Ramage]

Try this:

Sub DoStuff()
Const cFolderRoot As String = "C:\Documents and Settings\MyID\My Documents\"

Dim strKey As String, strFolder As String, strMainPath as string
Dim ws As Worksheet, wbMain As Workbook

Set wbMain = ActiveWorkbook 'get pointer to active workbook
strMainPath = wbMain.FullName
strKey = ActiveWorkbook.Sheets("Prod").Range("A1").Formula
strFolder = cFolderRoot & strKey
MkDir strFolder 'create new folder

For Each ws In wbMain.Worksheets 'loop through each worksheet in wbMain,
setting ws as a pointer to the current worksheet within the loop
ws.Copy 'copy this worksheet into new workbook
ActiveWorkbook.SaveAs Filename:=strFolder & "\" & strKey & "_" & ws.Name
& ".xls"
ActiveWorkbook.Close savechanges:=False
Next ws

wbMain.Close savechanges:=False
Kill strMainPath
End Sub

Not that this code must be run from a separate workbook or add-in as you
cannot delete the workbook that you are running the macro from.

Cheers,
Dave

 

[Bob Phillips]

Not that this code must be run from a separate workbook or add-in as you
cannot delete the workbook that you are running the macro from.

You can try this from the same workbook

With wbMain
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With

 

[kevinho]

Thanks guys, perfect result

Ke