Change code to make worksheets instead of workbooks

[mikeb1]

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").Value =
vntManager

'Create a new worksheet in the new workbook
wkbkNew.Sheets.Add before:=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

 

[Dianne]

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").Value =
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

 

[mikeb1]

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

 

[Dianne]

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").Value =
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