View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Ozzie via OfficeKB.com Ozzie via OfficeKB.com is offline
external usenet poster
 
Posts: 41
Default Creating New Workbook from Sheet

Hi, any help with the following would be really appreciated,

I have some VB Code, which works well, that for each change in a value in
column A creates a new sheet. However what I now need to do is to either;

a) create a new workbook for each of the newly created workshets, or
b) instead of creating a new sheet to directly create a workbook,

the ultimate end goal is to automatically email these workbooks or sheets.

my code for creating a new worksheet is

Sub create_new_sheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim lrow As Long

Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:z10000").CurrentRegion

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

With ws1
rng.Columns(1).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 WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False

Cells.Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select

WSNew.Columns.AutoFit
WSNew.Range("A1:A6").EntireRow.Insert
WSNew.Range("A7:C8").Copy WSNew.Range("D3")
WSNew.Columns("A:C").Delete
WSNew.Columns("A").AutoFit

End Sub

Many thanks

--
Message posted via http://www.officekb.com