Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change code to make worksheets instead of workbooks
I finally came across a post for someone else that had code to do what I
want, but with a slight variation: I want to make multiple worksheets, and this code makes multiple workbooks from one worksheet. The problem is... From one sheet: 10 ABC ... 10 ABC ... 20 EFG ... 20 EFG ... 20 EFG ... 20 EFG ... 30 QRS ... 30 QRS ... 30 QRS ... I would want multiple sheets: Sheet A = 10 ABC ... 10 ABC ... Sheet B = 20 EFG ... 20 EFG ... 20 EFG ... 20 EFG ... Sheet C = 30 QRS ... 30 QRS ... 30 QRS ... Here is the code: Sub CreateWorkbooks() Dim wkbkCurrent As Workbook Dim wkbkNew As Workbook Dim wsData As Worksheet Dim wsFilter As Worksheet Dim ws As Worksheet Dim cell As Range Dim colManagers As New Collection Dim vntManager As Variant Dim lngNumRows As Long Dim strName As String Set wkbkCurrent = ActiveWorkbook Set wsData = wkbkCurrent.Worksheets("MyData") Set wsFilter = wkbkCurrent.Worksheets("MyFilter") Application.StatusBar = "Creating workbooks. Please wait..." Application.ScreenUpdating = False 'Count the number of rows lngNumRows = wsData.Range("A" & Rows.Count).End(xlUp).Row 'Create a collection of managers from values in column A On Error Resume Next For Each cell In wsData.Range("A2:A" & lngNumRows) colManagers.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 'Filter on each manager, create workbook, 'save workbook and close workbook For Each vntManager In colManagers Set wkbkNew = Application.Workbooks.Add 'Put the manager's name into the filter criteria range wkbkCurrent.Worksheets("MyFilter").Range("A2").Val ue = vntManager 'Create a new worksheet in the new workbook wkbkNew.Sheets.Add befo=wkbkNew.Worksheets("Sheet1") Set ws = ActiveSheet 'Change the sheet name ws.Name = vntManager 'Filter the data based on your criteria range 'and copy the filtered data to the new workbook wsData.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsFilter.Range("A1:A2"), _ CopyToRange:=ws.Range("A1") 'Create a file name, save and close strName = "C:\MyFiles\" & "MyData " & vntManager wkbkNew.SaveAs (strName) wkbkNew.Close (False) Next vntManager LeaveSub: Set colManagers = Nothing Set cell = Nothing Set wsData = Nothing Set ws = Nothing Set wsFilter = Nothing Set wkbkNew = Nothing Set wkbkCurrent = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Another problem I'm having is that there are 3 blank colums which need to stay in the worksheet - but this code stops copying data when it hits a blank column. Thanks in advance for the help -Mike --- Message posted from http://www.ExcelForum.com/ |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change code to make worksheets instead of workbooks
Mike,
Another problem I'm having is that there are 3 blank colums The code uses AdvancedFilter to filter your data. Where it reads: wsData.Range("A1").CurrentRegion.AdvancedFilter _ it is auto-detecting your range, but CurrentRegion doesn't allow for blank columns, and, now that I have tested it, it doesn't seem like AdvancedFilter does either. Is there any way you can restructure your worksheet to get rid of those 3 blank columns? If not, you might have to use a different method to do this -- like looping through each row and copying the row to different worksheets. Or I could modify the code to delete the columns, then do the filter, then insert the blank columns back afterwards. Maybe someone else knows how to make AdvancedFilter co-operate with blank columns. Anyway, let me know what you want to do. In the meantime, the code below should create worksheets instead of workbooks (but you'll still have the problem with the blank columns). Caveat: the code below does not check to see if you already have a worksheet with the same name -- it will fall over if it finds one. Try this: Sub CreateWorksheets() Dim wkbkCurrent As Workbook Dim wsData As Worksheet Dim wsFilter As Worksheet Dim ws As Worksheet Dim cell As Range Dim colManagers As New Collection Dim vntManager As Variant Dim lngNumRows As Long Set wkbkCurrent = ActiveWorkbook Set wsData = wkbkCurrent.Worksheets("MyData") Set wsFilter = wkbkCurrent.Worksheets("MyFilter") Application.StatusBar = "Creating workbooks. Please wait..." Application.ScreenUpdating = False 'Count the number of rows lngNumRows = wsData.Range("A" & Rows.Count).End(xlUp).Row 'Create a collection of managers from values in column A On Error Resume Next For Each cell In wsData.Range("A2:A" & lngNumRows) colManagers.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 'Filter on each manager, create workbook, 'save workbook and close workbook For Each vntManager In colManagers 'Put the manager's name into the filter criteria range wkbkCurrent.Worksheets("MyFilter").Range("A2").Val ue = vntManager Set ws = wkbkCurrent.Worksheets.Add 'Change the sheet name ws.Name = vntManager 'Filter the data based on your criteria range 'and copy the filtered data to the new workbook wsData.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsFilter.Range("A1:A2"), _ CopyToRange:=ws.Range("A1") Next vntManager LeaveSub: Set colManagers = Nothing Set cell = Nothing Set wsData = Nothing Set ws = Nothing Set wsFilter = Nothing Set wkbkCurrent = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub -- HTH, Dianne In , mikeb1 typed: I finally came across a post for someone else that had code to do what I want, but with a slight variation: I want to make multiple worksheets, and this code makes multiple workbooks from one worksheet. The problem is... From one sheet: 10 ABC ... 10 ABC ... 20 EFG ... 20 EFG ... 20 EFG ... 20 EFG ... 30 QRS ... 30 QRS ... 30 QRS ... I would want multiple sheets: Sheet A = 10 ABC ... 10 ABC ... Sheet B = 20 EFG ... 20 EFG ... 20 EFG ... 20 EFG ... Sheet C = 30 QRS ... 30 QRS ... 30 QRS ... Here is the code: Sub CreateWorkbooks() Dim wkbkCurrent As Workbook Dim wkbkNew As Workbook Dim wsData As Worksheet Dim wsFilter As Worksheet Dim ws As Worksheet Dim cell As Range Dim colManagers As New Collection Dim vntManager As Variant Dim lngNumRows As Long Dim strName As String Set wkbkCurrent = ActiveWorkbook Set wsData = wkbkCurrent.Worksheets("MyData") Set wsFilter = wkbkCurrent.Worksheets("MyFilter") Application.StatusBar = "Creating workbooks. Please wait..." Application.ScreenUpdating = False 'Count the number of rows lngNumRows = wsData.Range("A" & Rows.Count).End(xlUp).Row 'Create a collection of managers from values in column A On Error Resume Next For Each cell In wsData.Range("A2:A" & lngNumRows) colManagers.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 'Filter on each manager, create workbook, 'save workbook and close workbook For Each vntManager In colManagers Set wkbkNew = Application.Workbooks.Add 'Put the manager's name into the filter criteria range wkbkCurrent.Worksheets("MyFilter").Range("A2").Val ue = vntManager 'Create a new worksheet in the new workbook wkbkNew.Sheets.Add befo=wkbkNew.Worksheets("Sheet1") Set ws = ActiveSheet 'Change the sheet name ws.Name = vntManager 'Filter the data based on your criteria range 'and copy the filtered data to the new workbook wsData.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsFilter.Range("A1:A2"), _ CopyToRange:=ws.Range("A1") 'Create a file name, save and close strName = "C:\MyFiles\" & "MyData " & vntManager wkbkNew.SaveAs (strName) wkbkNew.Close (False) Next vntManager LeaveSub: Set colManagers = Nothing Set cell = Nothing Set wsData = Nothing Set ws = Nothing Set wsFilter = Nothing Set wkbkNew = Nothing Set wkbkCurrent = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Another problem I'm having is that there are 3 blank colums which need to stay in the worksheet - but this code stops copying data when it hits a blank column. Thanks in advance for the help -Mike --- Message posted from http://www.ExcelForum.com/ |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change code to make worksheets instead of workbooks
Thanks alot Dianne. Seems to work great. Yeah, there are three blan
columns which can be taken out and then re-added later. The onl criteria is each worksheet needs three blank colums inserted after th "E" column. I can delete the three columns beforehand. Do you kno the code to do this, or could you put that mod. in my code for me? Thanks a million - you saved me a great deal of hand labor. -Mik -- Message posted from http://www.ExcelForum.com |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change code to make worksheets instead of workbooks
Sub CreateWorksheets()
Dim wkbkCurrent As Workbook Dim wsData As Worksheet Dim wsFilter As Worksheet Dim ws As Worksheet Dim cell As Range Dim colManagers As New Collection Dim vntManager As Variant Dim lngNumRows As Long Set wkbkCurrent = ActiveWorkbook Set wsData = wkbkCurrent.Worksheets("MyData") Set wsFilter = wkbkCurrent.Worksheets("MyFilter") Application.StatusBar = "Creating workbooks. Please wait..." Application.ScreenUpdating = False 'Count the number of rows lngNumRows = wsData.Range("A" & Rows.Count).End(xlUp).Row 'Create a collection of managers from values in column A On Error Resume Next For Each cell In wsData.Range("A2:A" & lngNumRows) colManagers.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 'Delete 3 columns wsData.Range("F:H").EntireColumn.Delete 'Filter on each manager, create workbook, 'save workbook and close workbook For Each vntManager In colManagers 'Put the manager's name into the filter criteria range wkbkCurrent.Worksheets("MyFilter").Range("A2").Val ue = vntManager Set ws = wkbkCurrent.Worksheets.Add 'Change the sheet name ws.Name = vntManager 'Filter the data based on your criteria range 'and copy the filtered data to the new workbook 'Make sure your range refers to the new, smaller range 'now that you have deleted your columns wsData.Range("A1:G10").AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsFilter.Range("A1:A2"), _ CopyToRange:=ws.Range("A1") 'Insert blank columns in new worksheet ws.Range("F:H").EntireColumn.Insert Next vntManager 'Insert 3 columns in original worksheet wsData.Range("F:H").EntireColumn.Insert LeaveSub: Set colManagers = Nothing Set cell = Nothing Set wsData = Nothing Set ws = Nothing Set wsFilter = Nothing Set wkbkCurrent = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub -- HTH, Dianne In , mikeb1 typed: Thanks alot Dianne. Seems to work great. Yeah, there are three blank columns which can be taken out and then re-added later. The only criteria is each worksheet needs three blank colums inserted after the "E" column. I can delete the three columns beforehand. Do you know the code to do this, or could you put that mod. in my code for me? Thanks a million - you saved me a great deal of hand labor. -Mike --- Message posted from http://www.ExcelForum.com/ |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
vba code to open workbooks | Excel Worksheet Functions | |||
Copy/ move selected data from workbooks to seperate worksheets or workbooks | Excel Worksheet Functions | |||
how do i change or make this macro??? pictures and code included | Charts and Charting in Excel | |||
Need code to protect worksheets - amount of worksheets varies | Excel Programming | |||
VBA code for looping through open workbooks and worksheets | Excel Programming |