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]

This line finds the last used row based on column A.

FinalRow = Cells(65536, 1).End(xlUp).Row

If column A has no data or less data than column D, you could get errors or unexpected results. Maybe try finding the FinalRow based on column D

FinalRow = Cells(Rows.Count, "D").End(xlUp).Row

 

[PB7]

Thanks AlphaFrog, let me try that right now, and report back.

 

[PB7]

Unfortunately, with that adjustment, I still get stuck at this point of the code below, and the VBA error message is:

Run-time error 1004 "The extract range has a missing or illegal field name"


Does that error message make any sense in the context of what I'm trying to do here? Many thanks.


Code gets stuck here:

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

 

[AlphaFrog]

Is cell D1 empty or does it have a formula in it?

If cell D1 has a formula, try changing this...
Range("D1").Copy Destination:=Cells(1, NextCol)

To this...
Cells(1, NextCol).Value = Range("D1").Value

 

[PB7]

No, D1 in my data, I don't has a formula, nor is blank. But let me double-check now, to be sure.

Thanks for the nice help here.

 

[Norie]

It looks like the destination of the unique list is on the same worksheet as the data?

Is that right?

 

[PB7]

Alphafrog, I made sure the unique value column was all text value, with no missing value or formula bogeys as far as I could tell. My dataset looks very similar to an original dataset that works well with this code.

 

[PB7]

The designated column of unique values looks good...no missing value or formula bogeys. I also reformatted the column to all text...still no luck in running.

 

[PB7]

Norie, yes, the destination of the unique list is on the same spreadsheet. Each unique value then generates a block of line items, say, 5, 10, or 20 different rows of line items. (from an array) Once there is a complete list of line items, for the unique value, say 15 items for John Doe, for example, those 15 rows get copied into a new spreadsheet, elsewhere, which is named John Doe.xls. If the code works, which is doesn't, with my data. Thanks.