Excel 2007 VBA - Filter to worksheets with header,footer and set print 2

[BxWill]

Assistance needed!

Have a 5000+ record Excel 2007 worksheet with data populated from column A through column R and using vba to filter on column P that contains the vendor names.

Using the code below, I was initially able to filter the data to several worksheets within the Excel workbook.

Then, modified code to display headers, footers and auto set the print area on each worksheet that was newly created.

Problem arose - Error message received is

"Run time error '1004' Method 'Range' of object'_Global failed.

Upon trying to debug, the code that is highlighted is the line that displays "Set rng = Range("Database")

Over the past two hours, I am not able to resolve.

What modifications should be made so that the;
1. Center Header for each newly created worksheet equals the vendor name
2. Left footer displays "Monthly Report, as of todays date"
3. Right footer displays the page numbering (i.e. page 1 of 3)?

Thanks in advance.

Option Explicit

Sub ExtractVendor()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
'Dim x As Long
'Dim lastCell As Range

Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")
'extract a unique list of Vendors
ws1.Columns("P").Copy _
Destination:=Range("W1")
ws1.Columns("W:W").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("U1"), Unique:=True
r = Cells(Rows.Count, "U").End(xlUp).Row

'set up Criteria Area
Range("W1").Value = Range("P1").Value

For Each c In Range("U2:U" & r)
'add the rep name to the criteria area
ws1.Range("W2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("W1:W2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("W1:W2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If

'Initially added the six lines below and then commented out the auto set print area portion

wsNew.PageSetup.CenterHeader = c.Value
wsNew.PageSetup.LeftFooter = "Monthly Report, as of now()"
wsNew.PageSetup.RightFooter = "Page 1 of 2"
' x = ActiveSheet.UsedRange.Columns.Count
' Set lastCell = Cells.SpecialCells(xlCellTypeLastCell)
' ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).Address
Next
ws1.Select
ws1.Columns("U:W").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[xlbo]

Set wsNew = Sheets.Add

will set the focus to a new worksheet.

the range ("Database") does not exist on this sheet hence the error.
change:
Set rng = Range("Database")
to:
Set rng = Ws1.Range("Database")

(or refer to whichever sheet that range name exists on

For the header / footer:

With wsNew.Pagesetup
.CenterHeader = c.Value
.LeftFooter = "Monthly Report as of " & format(now(),"dd/mm/yyyy")
.RightFooter = "Page &P of &N"
End with

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[BxWill]

Appreciate the insight. Will try the modifications...

Any thoughts as to vba that will automatically set up the print area for each newly created worksheet?

Currently trying the following

' x = ActiveSheet.UsedRange.Columns.Count ' Set lastCell = Cells.SpecialCells(xlCellTypeLastCell) ' ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).AddressNext

 

[PHV]

Like this ?

With wsNew.PageSetup
        .CenterHeader = c.Value
        .LeftFooter = "Monthly Report as of " & format(now(),"dd/mm/yyyy")
        .RightFooter = "Page &P of &N"
        [!].PrintArea = ""[/!]
End with

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886