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/