Solved: Simple VB? Take one file and make many

[eversharp]

I have a simple excel file that is setup like this:

Name|Month|Revenue
John|June|$1,000
John|July|$2,000
Tom|June|$500
Tom|August|$600
Suzy|October|$240

I want to create a macro that once ran, creates separate excel files for each person. So after running the Macro, I would see a john.xls file that would just be his two records... and then a tom.xls file that would be his two records, and finally a Suzy.xls file that would be her one record.

Can anyone help or point me to some syntax that does something like this? Thanks

[eversharp]

Any ideas?

[mancubus]

hi.
test with representative files



Function FilterAndCopy(rng As Range, Choice As String)
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=786

Dim FiltRng As Range

rng.AutoFilter Field:=1, Criteria1:=Choice

On Error Resume Next
Set FiltRng = rng.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0

FiltRng.Copy
Workbooks.Add 1
ActiveSheet.Paste
ActiveWorkbook.SaveAs "C:\My Documents\" & Choice, 56 'change to suit, 56 for XLS file format
ActiveWorkbook.Close False

End Function


Sub MakeMultiFilesFromRange()
'http://www.vbaexpress.com/forum/showthread.php?t=43236

Dim rng As Range, cll As Range
Dim temp As String, arrUnq() As String
Dim i As Integer, Calc As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

On Error GoTo exit_sub:

Set rng = ActiveSheet.UsedRange

For Each cll In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(2)
If InStr(temp, cll.Value) = 0 Then temp = temp & "|" & cll.Value
Next

arrUnq = Split(Mid(temp, 2, Len(temp)), "|")

For i = LBound(arrUnq) To UBound(arrUnq)
FilterAndCopy rng, arrUnq(i)
rng.AutoFilter
Next

exit_sub:

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = Calc
End With

End Sub

[GTO]

I have a simple excel file that is setup like this:

Name|Month|Revenue
John|June|$1,000
John|July|$2,000
Tom|June|$500
Tom|August|$600
Suzy|October|$240

I want to create a macro that once ran, creates separate excel files for each person. So after running the Macro, I would see a john.xls file that would just be his two records... and then a tom.xls file that would be his two records, and finally a Suzy.xls file that would be her one record.

Can anyone help or point me to some syntax that does something like this? Thanks

Greetings eversharp,

At least for me, your question could have included a smattering more detail. You were clear in saying that 'Tom' should result in a wb, but are the record/s simply on one sheet, or, are we splitting months to different sheets?

Mark

[eversharp]

GTO, the sheet doesn't have to break down by month, so all Tom's records would be on one sheet regardless of Month

Mancubus, I will try your code!

[snb]

or
Sub snb()
with ThisWorkbook
Do Until .Sheets(1).Columns(1).SpecialCells(2).Count = 1
c01 = .Sheets(1).Cells(2, 1).Value
Workbooks.Add

With .Sheets(1).Cells(1).CurrentRegion
.AutoFilter 1, c01
.Copy ActiveWorkbook.Sheets(1).Cells(1)
.Offset(1).EntireRow.Delete
.AutoFilter
End With

ActiveWorkbook.SaveAs .Path & "\" & c01, .FileFormat
ActiveWorkbook.Close False
Loop
end with
End Sub

[GTO]

Another take:

Option Explicit

Enum FileFormat
xlWorkbookNormal = &HFFFFEFD1
' At home, and being as I have the memory of a gnat... not sure of value to below
xlExcel8 = &HFFFFEFD1
End Enum

Sub SplitFile()
Dim DIC As Object ' Dictionary
Dim aryUniques As Variant
Dim aryIndividualData As Variant
Dim aryHolder As Variant
Dim n As Long
Dim wb As Workbook

Dim FFormat As FileFormat

Application.ScreenUpdating = False
'// Assumes worksheet w/default codename of Sheet1 contains data in first three //
'// columns, starting at row 2. //
With Sheet1
aryUniques = _
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3).Value
End With
'// Create a NEW dictionary and Set a reference to it. //
Set DIC = CreateObject("Scripting.Dictionary")
With DIC

'// For each "Row" in our snatched-up values... //
For n = 1 To UBound(aryUniques, 1)
'// ...see if the name already exists. If NOT... //
If Not .Exists(aryUniques(n, 1)) Then
'// create a new oversized array. As we are creating new sheets //
'// (one in ea new wb), I see no harm in oversizing the rows. //
ReDim aryIndividualData(1 To UBound(aryUniques, 1), 1 To 3)
'// Use one element in the first "row" to hold a 'counter', to see //
'// where to plunk the next values. //
aryIndividualData(1, 3) = 1
'// Use the rows in the first two columns to hold our values from //
'// this person's sales. //
aryIndividualData(1, 1) = aryUniques(n, 2)
aryIndividualData(1, 2) = aryUniques(n, 3)
'// Dump our initial array for this person into the .Key's .Item. //
.Add aryUniques(n, 1), aryIndividualData
Else
'// If there is a way to access/change the elements in the array //
'// while it is still held as an .Item in the Dictionary, I am //
'// unfortunately, lacking... Thus: //
'// Use a temp/dynamic array to hold the current array stored in the//
'// .Item for the Key. //
aryHolder = .Item(aryUniques(n, 1))
'// Add to our counter. //
aryHolder(1, 3) = aryHolder(1, 3) + 1
'// Plunk the current record's values into the correct "row" of the //
'// 'holder' array. //
aryHolder(aryHolder(1, 3), 2) = aryUniques(n, 3)
aryHolder(aryHolder(1, 3), 1) = aryUniques(n, 2)
'// Overwrite the current .Item's array with our updated array. //
.Item(aryUniques(n, 1)) = aryHolder
End If
Next

'// Due to a quirk in Dictionary, in order to access the individual .Items()//
'// and .Keys(), we need an array to hold. Technically, I belileve this //
'// would be a "jagged edged" array, but as both elements of the 1D array //
'// hold equally sized 1D arrays - I'm not sure that's utterly correct. //
'// Regardless, we have an "array of arrays". //
aryHolder = Array(.Keys, .Items)
End With

'// I am afraid my description lacks, but for each element in the outer array's //
'// first dimension of the inner array... //
For n = LBound(aryHolder(0), 1) To UBound(aryHolder(0), 1)
'//... plunk the values into a new wb. //
With Workbooks.Add(xlWBATWorksheet)
.Worksheets(1).Range("A2").Resize(UBound(aryHolder(1)(n), 1), 2).Value = aryHolder(1)(n)

If Val(Application.Version) > 9 Then
FFormat = xlExcel8
Else
FFormat = xlWorkbookNormal
End If

.SaveAs Filename:=ThisWorkbook.Path & "\" & aryHolder(0)(n), _
FileFormat:=FFormat

.Close False
End With
Next
Application.ScreenUpdating = True
End Sub

[eversharp]

Thanks all! Mancubus's solution worked, although I think the other two would work fine as well!