VBA filter for unique values and copy

[PB7]

All,

I have some VBA code obtained via Mr Excel, and it works great with the sample data that came with it.

<TABLE style="WIDTH: 384pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=512 border=0><COLGROUP><COL style="WIDTH: 48pt" span=8 width=64><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-RIGHT: #f0f0f0; BORDER-TOP: #f0f0f0; BORDER-LEFT: #f0f0f0; WIDTH: 384pt; BORDER-BOTTOM: #f0f0f0; HEIGHT: 12.75pt; BACKGROUND-COLOR: transparent; mso-ignore: colspan" width=512 colSpan=8 height=17>This is a great reporting tool - it creates multiple reports on the C:\ drive in about a minute, based on the unique values in the customer column. It is here below.


Sub RunReportForEachCustomer()

Dim IRange As Range
Dim ORange As Range
Dim CRange As Range
Dim WBN As Workbook
Dim WSN As Worksheet
Dim WSO As Worksheet

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

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

' First - get a unique list of customers in J
' Set up output range. Copy heading from D1 there
Range("D1").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(65536, NextCol).End(xlUp).Row

' 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("D1").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 = "Report of Sales to " & ThisCust

' Copy data from WSO to WSN
WSO.Cells(1, NextCol + 4).CurrentRegion.Copy Destination:=WSN.Cells(3, 1)
TotalRow = WSN.Cells(65536, 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 "E:\EdsProject2\" & 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

</TD></TR></TBODY></TABLE>

Always some sort of error when I try to modify to data that I need handled the same way.

2 things usually happen. 90% of time, I get stuck here, at the filter:

IRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", CopyToRange:=ORange, Unique:=True

My result is usually the code ends there.

Or about 10% of the time, I get the multiple new files created, but they do not have to filtered/copied data that I was expecting in the new files.

Would anyone know what I am doing wrong?

Thank you very much.

 

[AlphaFrog]

What exactly is in cell D1 as seen in the formula bar when you select D1?