Creating New Workbook from Sheet
in [Programming]
|
Prev: Large footnote
Next: Updating Excel QueryTable using VB
From: Ozzie via OfficeKB.com on 18 Jan 2010 16:33 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
From: Ron de Bruin on 18 Jan 2010 16:35 Try this example http://www.rondebruin.nl/copy5_3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote in message news:a250009bc86a2(a)uwe... > 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 >
From: Ron de Bruin on 18 Jan 2010 16:44 Oops I missed that >> the ultimate end goal is to automatically email these workbooks or sheets. If you want to mail it directly see http://www.rondebruin.nl/mail/folder2/row2.htm Or if you use Outlook http://www.rondebruin.nl/mail/folder2/row2.htm Or body http://www.rondebruin.nl/mail/folder3/row2.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" <rondebruin(a)kabelfoon.nl> wrote in message news:OVCUtYImKHA.5020(a)TK2MSFTNGP02.phx.gbl... > Try this example > http://www.rondebruin.nl/copy5_3.htm > > -- > > Regards Ron de Bruin > http://www.rondebruin.nl/tips.htm > > > "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote in message news:a250009bc86a2(a)uwe... >> 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 >>
From: Gord Dibben on 18 Jan 2010 16:57 Since you have already created the sheets you can run this macro to save each sheet as its own workbook. Sub Make_New_Books() Dim w As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False For Each w In ActiveWorkbook.Worksheets w.Copy With ActiveWorkbook .SaveAs FileName:=ThisWorkbook.Path _ & "\" & w.Name & ".xlsx" .Close End With Next w Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Or see Ron de Bruin's site for code to create new workbooks directly from unique values. http://www.rondebruin.nl/copy5.htm Gord Dibben MS Excel MVP On Mon, 18 Jan 2010 21:33:14 GMT, "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote: >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
From: Ozzie via OfficeKB.com on 18 Jan 2010 17:24
Ron de Bruin wrote: >Try this example >http://www.rondebruin.nl/copy5_3.htm > >> Hi, any help with the following would be really appreciated, >> >[quoted text clipped - 68 lines] >> >> Many thanks Many thanks for all responses, Ron, Many thanks for your speedy response, the example spreadsheet with the code that saves the workbooks into a folder and then creates a hyperlink is really 'spot on' and is something I hadn't considered. This is really efficient and gets me around any company email limits!, Thanks alot -- Message posted via http://www.officekb.com |