View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Ron de Bruin Ron de Bruin is offline
external usenet poster
 
Posts: 11,123
Default New Workbooks for unique values

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

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

--
Regards Ron de Bruin
http://www.rondebruin.nl



wrote in message oups.com...
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(befo=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