New Workbooks for unique values

[brianl]

I am working on a macro that will look in a particular column(In this
case it is Column D referred to by 4 in the code below) and create a
new workbook for each unique value in Col D and then populate the new
workbook with all rows from the original workbook containing the unique
value in Col D; this will then loop back to create workbooks for each
unique value in all rows in the original workbook.
I of course copied this code from another helpful group member, and it
works great except at the end because although it creates the new
workbooks I want I run into a "Runtime Error '91' Object Variable or
With Block variable not set
The code below falls below other code in a longer macro which all works
fine. This code even works, but I am left with Sheet 10 and NewCash on
the original workbook - which is nice, but I would like the code not to
fail at the end.
Any help is greatly appreciated - I am stuck
I am working with Excel 2000.
Sheets("NewCash").Select
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = NewCash
'KeyCol = InputBox("What column # within database to use as key?")
KeyCol = 4
Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1,
0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(CStr(myCell.Value)).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(before:=Worksheets(1))
***The line below this is highlighted as the culprit of doom***
mySht.Name = CStr(myCell.Value)
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=CStr(myCell.Value)
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell
'Optional section to export the sheets to separate files
For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs ActiveSheet.Name & "NewCash " & ".xls"
End If
Next mySht
End Sub
Oh and if you can tell me how to direct the save location to something
specific that would be great because as it stands it always seems to
save the new workbooks willy-nilly to some file location I save
something else to earlier - generally the desktop.
Thanks
Brian

 

[Ron de Bruin]

Look on this page
http://www.rondebruin.nl/copy5.htm

Try this
http://www.rondebruin.nl/copy5.htm#workbook

 

[Bielle]

Ron,
Thanks for the response. I am still relatively new to writing macros,
so hopefully this next problem isn't too basic, but when I run the code
in excel for the workbook in question I receive an error when the code
tries to set WS1

Set ws1 = ThisWorkbook.Sheets("NewCash") '<<< Change

I thought that this referred to the name of the sheet which I wish to
manipulate, but it says that the subscript is out of range. Any advice
on why this would fail. The sheet will always be named "NewCash" as I
add this worksheet earlier in the macro with this name with the
following
ActiveWorkbook.Worksheets.Add.Name = "NewCash"

And for this command -
WBNew.SaveAs FileFolder & Format(Now, "yyyy-mmm-dd hh-mm-ss") & " Value
= " & cell.Value
WBNew.SaveAs "H:\Operations\Daily Activities\DayMan New Cash", & "
Value = " & cell.Value
How can I specify a place - always the same place for the new workbooks
to go, and I would like the filename to be the cell value from the
column indicated(4 in this case) but not the header with "NewCash"
following it.
I tried
ActiveWorkbook.SaveAs ActiveSheet.Name & "NewCash " & ".xls"
but that only worked when the name for the new sheet in the new
workbook created from the master workbook copied the unique value for
which the workbook was created e.g. if KT were one of the unique values
I would like the workbook to save as KTNewCash.
Thanks again for your help.

 

[Ron de Bruin]

Set ws1 = ThisWorkbook.Sheets("NewCash") '<<< Change
This is the sheet with the data

Is the code also in this workbook with this sheet ?

Do you have one header row in your data ?

 

[Bielle]

Ron,
I appreciate your help, and your site has been a great resource for
learning macros. To make it easier, and because it is short - here is
the whole deal. It opens a user defined report which will always have
"Posted" as the main sheet - it then highlights values over 9999 with
yellow and pastes that onto a new sheet called "AllansNewCash" and
deletes "Posted". It then saves this file before copying all of the
data into a new sheet "NewCash" and deletes "AllansNewCash" (I keep
copying and pasting wholes sheets onto new ones and deleting them
because I had some issues with the advanced filter making it difficult
to maintain the format, but it works fine with this fix).
This is when I was hoping to invoke your code to create new workbooks
for all rows containing the same unique value in column D with header
name "Day Man" and loop back for all unique values while saving them to
a specific place with a particular name that excel would create. I
would like the new workbooks to remain open.
And there is one header row out to Column O.
Sub Test()
Application.ScreenUpdating = False

Dim F As Variant
Dim wkb As Workbook
F = Application.GetOpenFilename("Excel-files,*.xls", , "Open
New Cash report for which you wish to run Day Man New Cash Reports.")
If F = False Then Exit Sub
For Each wkb In Application.Workbooks
If wkb.Path & "\" & wkb.Name = F Then
MsgBox "File " & wkb.Name & " is already open"
Exit Sub
End If
Set wkb = Workbooks.Open(F)
Next
Workbooks.Open Filename:=F
Range("A1").Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Rows("5:5").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("B2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "li"
Range("B3").Select
ActiveCell.FormulaR1C1 = "sa"
Cells.Select
Range("A1:O5000").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:= _
Range("A1:O3"), Unique:=False
ActiveWorkbook.Worksheets.Add.Name = "AllansNewCash"
Sheets("Posted").Select
Cells.Select
Selection.Copy
Sheets("AllansNewCash").Select
ActiveSheet.Paste
Sheets("Posted").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Rows("2:3").Select
Selection.Delete Shift:=xlUp
Columns("N:N").EntireColumn.AutoFit
Cells.Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression,
Formula1:="=$N1>9999"
Selection.FormatConditions(1).Interior.ColorIndex = 6
fileSaveName = Application.GetSaveAsFilename( _
filefilter:="Excel Files (*.xls), *.xls")

If fileSaveName <> False Then
ActiveWorkbook.SaveAs Filename:=fileSaveName,
FileFormat:=xlNormal

MsgBox "Save as " & fileSaveName
End If

Sheets("AllansNewCash").Select
Cells.Select
Selection.Copy
ActiveWorkbook.Worksheets.Add.Name = "NewCash"
Sheets("NewCash").Select
ActiveSheet.Paste
Columns("N:N").EntireColumn.AutoFit
Sheets("AllansNewCash").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("NewCash").Select

Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FileFolder As String



FileFolder = "C:\Documents and Settings\brianl\Desktop\" '<<<
Change
Set ws1 = ThisWorkbook.Sheets("newcash") '<<< Change

'Tip : You can also use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1:O10000").CurrentRegion '<<< Change



With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With



With ws1
'This example filter on the first column in the range (change
this if needed)
'You see that the last two columns of the worksheet are used to
make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use
the columns)
rng.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True



Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value



For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Set WBNew = Workbooks.Add
On Error Resume Next
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _

CopyToRange:=WBNew.Sheets(1).Range("A1"), _
Unique:=False
WBNew.Sheets(1).Columns.AutoFit
WBNew.SaveAs ("H:\Operations\Daily Activities\DayMan New
Cash", & " Value = " & cell.Value
WBNew.Close False
Next
.Columns("IU:IV").Clear
End With



With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
These macros are a great challenge, and I appreciate the group's, and
especially Ron's , efforts in educating people new to the art like
myself.
Thanks,
Brian

 

[Ron de Bruin]

I go to London now so I try to answer it Sunday when I am back