PDA

View Full Version : Save different filename based on multiple selection



ylai20
10-26-2009, 11:57 PM
Hi, i am using Excel 2007. I wanna spread my excel file into different file name based on the customer code.
For example: My excel has 3 columns: Cust Code, Cust Name and Sales Amt.

Cust Code: C01, C02...C10

How to create a micro so that it will automatically select only C01 record and save as C01_31-09-2009.xls, C02 record as C02_31-09-2009.xls....

Means i will have 10 excel files with different cust code..

Would be appreciate someone can advise me on this..Thanks!

GTO
10-27-2009, 12:11 AM
Greetings ylai20,

When you say it will "select only C01 record...", what is the C01 record comprised of? Just that row, or a sheet in the workbook, or???

Mark

PS - Say, I see that this is your first post :-) Welcome to the forum. I'm sure you'll be glad you joined, as there's some super nice and helpful folks here :-)

ylai20
10-27-2009, 05:51 AM
Thanks for your reply.
In one sheet, there is many records. And let says column A is Cust Code. I want to filter it by Cust Code C01, and save it as C01.xls. So in the C01.xls, inside only got C01 data.

The other column will also list down and depends on the cust code.

Attached is the sample.
Master file will spread into different file (C01.xls and C02.xls)

GTO
10-27-2009, 08:37 PM
...In one sheet, there is many records. And let says column A is Cust Code. I want to filter it by Cust Code C01, and save it as C01.xls. So in the C01.xls, inside only got C01 data...

Hi,

It appeared to me in the example data that you meant Col C has the customer codes.

As I am unsure of a dependable pattern to customer codes, the following requires that nothing besides the codes resides in Col C.

In a junk copy of your wb, try:

In a Standard Module:


Option Explicit

Sub Records_SplitToWorkbooks()
Dim _
FSO As Object, _
wbNew As Workbook, _
rngSearch As Range, _
rngMarker As Range, _
rngLRow As Range, _
rngToCopy As Range, _
strFirstAddress As String, _
strPath As String, _
strFileName As String, _
aryAddresses As Variant, _
i As Long
'//********* Change to suit ******* //
Const SH_NAME As String = "Sheet1" '//
strPath = ThisWorkbook.Path & "\" '//
'//**********************************//

With ThisWorkbook.Worksheets(SH_NAME)
'// Set a reference to the column with the customer codes. //
'// As we may or may not have a particluar pattern to customer codes, this //
'// requires that no values other than customer codes are in Col C, as we are //
'// looking for ANY value. //
Set rngSearch = .Range("C:C")
'// Reference the cell with the first customer code. //
Set rngMarker = rngSearch.Find(What:="*", _
After:=.Cells(Rows.Count, 3), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
'// A safety: in case we don't find anything, now would be a good time to bail //
If rngMarker Is Nothing Then Exit Sub

'// We'll use the address of the first customer code (CC) to know when to stop //
'// searching. //
strFirstAddress = rngMarker.Address
'// Initially size our array of addresses to one element and chunk in the address//
ReDim aryAddresses(1 To 1)
aryAddresses(1) = strFirstAddress
'// Loop to keep finding CCs until we 're-find' oour first one. //
Do
Set rngMarker = rngSearch.FindNext(After:=rngMarker)
If Not rngMarker Is Nothing And Not rngMarker.Address = strFirstAddress Then
'// Add another element to our array and add the additionale address. //
ReDim Preserve aryAddresses(1 To UBound(aryAddresses) + 1)
aryAddresses(UBound(aryAddresses)) = rngMarker.Address
End If
Loop While Not rngMarker Is Nothing And Not rngMarker.Address = strFirstAddress

'// Searching from the bottom of the sheet upwards, we find where the last row //
'// with any data in it is. This way, we know where our last customer's data //
'// ends. //
Set rngLRow = .Cells.Find(What:="*", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)

'// We'll use FSO to see if a file has already been created for the record. //
Set FSO = CreateObject("Scripting.FileSystemObject")

'// Basically, for each element in our array of addresse... //
For i = LBound(aryAddresses) To UBound(aryAddresses)

'// First we'll create a string for the filename like: C01_31-09-2009.xls //
strFileName = .Range(aryAddresses(i)).Value & "_" & Format(Date, "dd-mm-yyyy")
'// If the file doesn't already exist... //
If Not FSO.FileExists(strPath & strFileName) Then
'// Set a reference to a newly created, one-sheet, workbook. //
Set wbNew = Workbooks.Add(xlWBATWorksheet)
'// Until we get to the last address... //
If Not i = UBound(aryAddresses) Then
'// ...we'll copy the rows from the row of the address we are //
'// currently at, to one row up from the row of the next address //
'// in our array; but... //
Set rngToCopy = Range(.Range(aryAddresses(i)).Offset(, -2), _
.Range(aryAddresses(i + 1)).Offset(-1, -2))
rngToCopy.EntireRow.Copy Destination:=wbNew.Worksheets(1).Range("A2")

Else
'// ...if we are at our last address, then we'll copy to the last row//
'// row of data. //
Set rngToCopy = Range(.Range(aryAddresses(i)).Offset(, -2), _
.Cells(rngLRow.Row, 1))
rngToCopy.EntireRow.Copy Destination:=wbNew.Worksheets(1).Range("A2")
End If

'// Tidy up, SaveAs, and close new wb. //
With wbNew
.Worksheets(1).Range("A1").Value = "Sales"
.Worksheets(1).Range("A1").Font.Bold = True
.Worksheets(1).UsedRange.Columns.EntireColumn.AutoFit
.SaveAs strPath & strFileName
.Close False
End With
End If
Next
End With
End Sub



Hope that helps,

Mark