Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
New Workbooks for unique values
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
New Workbooks for unique values
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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
New Workbooks for unique values
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 ? -- Regards Ron de Bruin http://www.rondebruin.nl "Bielle" wrote in message oups.com... 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. |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
New Workbooks for unique values
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:="=$N19999" 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 wrote: 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 ? -- Regards Ron de Bruin http://www.rondebruin.nl "Bielle" wrote in message oups.com... 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. |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
New Workbooks for unique values
I go to London now so I try to answer it Sunday when I am back
-- Regards Ron de Bruin http://www.rondebruin.nl "Bielle" wrote in message ups.com... 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:="=$N19999" 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 wrote: 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 ? -- Regards Ron de Bruin http://www.rondebruin.nl "Bielle" wrote in message oups.com... 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. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Unique Values, not Unique Records | Excel Discussion (Misc queries) | |||
Sorting unique values and returning values from a formula | Excel Programming | |||
Count unique values and create list based on these values | Excel Worksheet Functions | |||
create list of unique values from a column with repeated values? | Excel Worksheet Functions | |||
How do I search thr'o column and put unique values in differnt sheet and sum corresponding values in | Excel Programming |