Advanced fillter

[Razor303]

HI, have code from the man him self Mr Excel to do Advanced fillter, but the output range is for four Criteria I need it to set up a output range for 52 criteria. here is the first lines of code I think ill need to adjust.

Cells(1, NextCol + 4).Resize(1, 4).Value = Array(Cells(1, 3), Cells(1,5),Cells(1, 2), Cells(1, 6))
Set ORange = Cells(1, NextCol + 4).Resize(1, 4)

Here is the Sub

Sub CustomReport()

Dim IRange As Range ' Input Range
Dim ORange As Range ' Output Range
Dim CRange As Range ' Criteria Range
Dim WBN As Workbook ' New Workbook
Dim WSN As Worksheet ' New Worksheet
Dim WSO As Worksheet ' Original Worksheet

' Since this is called from a button on Menu,
' first select the sample data sheet
Worksheets("DATA").Select
' Clear out results of previous macros
Range("AZ1:XFD1").EntireColumn.Delete

Set WSO = ActiveSheet
' Find the size of today's dataset
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
NextCol = Cells(1, Columns.Count).End(xlToLeft).Column + 2

' First - get a unique list of customers in J
' Set up output range. Copy heading from D1 there
Range("A1").Copy Destination:=Cells(1, NextCol)
Set ORange = Cells(1, NextCol)

' Define the Input Range
Set IRange = Range("A1").Resize(FinalRow, NextCol - 2)

' Do the Advanced Filter to get unique list of customers
IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", CopyToRange:=ORange, Unique:=True

FinalCust = Cells(Rows.Count, NextCol).End(xlUp).Row

MyPath = ActiveWorkbook.Path & Application.PathSeparator

' Loop through each customer
For Each cell In Cells(2, NextCol).Resize(FinalCust - 1, 1)
ThisCust = cell.Value

' Set up the Criteria Range with one customer
Cells(1, NextCol + 2).Value = Range("A1").Value
Cells(2, NextCol + 2).Value = ThisCust
Set CRange = Cells(1, NextCol + 2).Resize(2, 1)

' Set up output range. We want Date, Quantity, Product, Revenue
' These columns are in C, E, B, and F
Cells(1, NextCol + 4).Resize(1, 4).Value = Array(Cells(1, 3), Cells(1, 5), Cells(1, 2), Cells(1, 6))
Set ORange = Cells(1, NextCol + 4).Resize(1, 4)

' Do the Advanced Filter to get unique list of customers & product
IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CRange, CopyToRange:=ORange
' Create a new workbook with one blank sheet to hold the output
Set WBN = Workbooks.Add(xlWBATWorksheet)
Set WSN = WBN.Worksheets(1)

' Set up a title on WSN
WSN.Cells(1, 1).Value = "Profile" & ThisCust

' Copy data from WSO to WSN
WSO.Cells(1, NextCol + 4).CurrentRegion.Copy Destination:=WSN.Cells(3, 1)
TotalRow = WSN.Cells(Rows.Count, 1).End(xlUp).Row + 1
WSN.Cells(TotalRow, 1).Value = "Total"
WSN.Cells(TotalRow, 2).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
WSN.Cells(TotalRow, 4).FormulaR1C1 = "=SUM(R2C:R[-1]C)"

' Format the new report with bold
WSN.Cells(3, 1).Resize(1, 4).Font.Bold = True
WSN.Cells(TotalRow, 1).Resize(1, 4).Font.Bold = True
WSN.Cells(1, 1).Font.Size = 18

WBN.SaveAs MyPath & ThisCust & ".xls"
WBN.Close SaveChanges:=False

WSO.Select
Set WSN = Nothing
Set WBN = Nothing

' clear the output range, etc.
Cells(1, NextCol + 2).Resize(1, 10).EntireColumn.Clear
Next cell

Cells(1, NextCol).EntireColumn.Clear
MsgBox FinalCust - 1 & " Reports have been created!"
End Sub

Thank to anyone how can help me with this one.

 

[GlennUK]

Describe, in English, what you are trying to achieve, instead of making people guess what that is from code.