Excel 2003 - automate multiple sheet creation

[Kevinski]

Hello

I have a variable length spreadsheet sorted by department (col B) and containing 8 columns of data.

From this master sheet 'Access Classes' I want to create a worksheet based on each change in col B and copy the relevant rows from the master to that sheet.

The dept names in col B are short enough to become the new sheets names.

I know there's a loop involved but I don't know where to start.........

 

[SkipVought]

Kevinski,

Why separate sheets?

Why not use AutoFilter?

Skip,

_{[red]Sign above the facsimile apparatus at the music publisher:[/red]
If it ain't baroque...
Don't FAX it!}

 

[Gavona]

Overview:
Use rangenames throughout
I'll assume that the Column Heading for the Departments Column is "Dept"
and that your database is assigned the rangename of "Alldata"

Create a worksheet for the unique list of dept names
In cell A5 type "Dept"
Give cell A5 the rangename "DeptList"
Use advanced filter to create a unique list of dept names (Copy to another location
List range: "DeptList"
Criteria range: leave this blank
Unique records only
The entire Dept list can now be referenced through code using Range("DeptList").CurrentRegion

Create a "results" worksheet to contain the data extracted

On this worksheet copy the column headings from your source data to A5 and name the range containing these headings "Extract"

Create a criteria range in A1:A2
In A1 type "Dept"
Give A1:A2 the RANGENAME "Criteria"

For each Mycell in DeptNames
Populate the second cell in the criteria range (A2) with Mycell.value (i.e. the dept name)
Apply advanced filter to new location ("Extract")
Copy the Results worksheet to a new sheet and give this sheet the name = mycell.value
Next Mycell

Before I go further.
The above will need slight modification if you have formulae in your database and you wish to preserve these in the extracted info.

But with only 8 columns a Pivottable may do the trick.

Thanks,

Gavin

 

[Kevinski]

Good point - the user wants to be able to e-mail each resultant sheet to someone in that dept and doesn't want any department to view anothers data.

I'm sure there's a bigger solution but at the moment all they've asked me to investigate is breaking the master sheet up.....I have pointed out that most of the repetitive-ness in this exercise is in the emailing (there's 25 depts) and maybe an autofilter/ lock cells solution is better.......but not sure how that would work either...

 

[Gavona]

Pivottable using show pages would be easiest. I have code that does either the filter method or by pivot tables. I'll see if I have it at home.

Thanks,

Gavin

 

[Kevinski]

Thanks for all your help so far.

 

[Gavona]

OK, the code I have around is a bit too tailored to be that helpful. There are several steps:

1. Getting a unique list of depts
2. Assigning an email address or addresses for each Depts data to be sent to. (Converting to array if multiple recipients)
3. Splitting up the data - use advanced filter or pivot table.
4. Fine-tuning the extrated data - If using advanced filter do you want to add subtotals? If using Pivot tables then formatting. Either way setting sensible print settings etc.
5. Emailing the sheets out including handling situations where email address fails or your mailbox is too full etc. (Do you want to include text in the body of the email or simply a header and attached file?)

Where do you want to start? This may help:

Sub EmailPivotSheets()

Dim WB As Workbook
Dim WS As Worksheet
Dim SendMail As Boolean
Dim DefaultAddress
Dim Month As String

Month = "August"
SendMail = False                   'False means don't send emails
DefaultAddress = "xxx@yy.gov.uk"

Set WB = ActiveWorkbook     'WB therefore refers to the workbook active when macro initiated
    
For Each WS In ActiveWorkbook.Worksheets
 Call Printsettings 
 WS.Copy        'creates separate workbook
 'Then send it
       sendto = MakeArrayOf(Range("B1").Value, ";")
       EmailTitle = "Monitoring " + mymonth + WS.Name
        
 'need to trap invalid email addresses
 On Error GoTo ErrorHandler
 If SendEmail Then ActiveWorkbook.SendMail _
   Recipients:=sendto, _
   Subject:=EmailTitle, _
   RETURNRECEIPT:=True
 On Error GoTo 0
'reset workbook ready for next loop
ActiveWorkbook.Close SaveChanges:=False
Next WS

Exit Sub

ErrorHandler:
  MsgBox Prompt = "Sendmail failure for " + r.Value + ".  Probably invalid email address " + SendTo + "sent to " + DefaultAddress
        EmailTitle = "FAILED EMAIL CHECK EMAIL ADDRESS " + r.Value
        r.Offset(0, 2).Value = "email failure"
        sendto = DefaultAddress
       ActiveWorkbook.SendMail Recipients:=sendto, Subject:=EmailTitle, RETURNRECEIPT:=True
        Resume Next
End Sub

Public Function MakeArrayOf(StringList As String, _
                 Delimiter As String) As Variant
Dim sWork As String
Dim A() As String
Dim nIndex As Integer
Dim nPos As Integer
  sWork = StringList
  ReDim A(1)
  nIndex = 0
  nPos = InStr(sWork, Delimiter)
  While nPos > 0
    ReDim Preserve A(nIndex)
    A(nIndex) = Left(sWork, nPos - 1)
    sWork = Mid(sWork, nPos + 1, 999)
    nIndex = nIndex + 1
    nPos = InStr(sWork, Delimiter)
  Wend
  If Len(sWork) > 1 Then
    ReDim Preserve A(nIndex)
    A(nIndex) = sWork
  End If
  MakeArrayOf = A
End Function

Thanks,

Gavin