O
Ozzie via OfficeKB.com
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
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