I didn't look at your code, but you may want to look at Data|Pivottable for this
kind of thing.

I think you'll find that it works much quicker.

The only warning I'd make is to add an extra column to use for the date:

=date(year(c2),month(c2),1)

That way your columns will be combined nicely.

I'd add that extra column
give it a nice header
Select the range
Data|Pivottable...
follow the wizard
drag the User to the row field
drag the product under the User in the row field
drag the modified date to the column field
drag the qty to the data field
if qty shows "count of qty", then double click on it and change it to "sum"

Finish the wizard

You can double click on each of the row items and hide subtotals if you want.

and if you need a macro for this, you can record it while you do it once.

I'd bet that the only thing you'll have to adjust is the input range for the
pivottable.



dolphin_ty wrote:

Dear all,

I have a piece of codes that used to convert live data to a report
format, it work fine while the data is small but when I feed more data
said 3000 records it will take around 4-5 mins and sometime hang !
My PC is PIII 700.

I do appreciate that someone can teach me how to improve the current
coding.

Thanks
Dolphin

Sample format

User product date Qty
a xx 1/1/00 10
b xy 1/2/02 2
c xz 1/2/01 5
a xx 1/10/00 1

after convert in a new worksheet

User product 1/00 2/00 ....1/01.......1/02.......12/02
a xx 11
b xy 2
c xz 5

Coding

Sub summary()

Application.ScreenUpdating = False
Application.EnableEvents = False
Dim r As Range, c As Range
ThisWorkbook.Sheets("summary").Cells.ClearContents

With ThisWorkbook.Sheets("Data")
Set r = Range(.Range("A2"), _
.Range("A" & Rows.Count).End(xlUp))
ThisWorkbook.Names.Add Name:="Customer", RefersTo:=r
ThisWorkbook.Names.Add Name:="Item_no", RefersTo:=r.Offset(0, 1)
ThisWorkbook.Names.Add Name:="dates", RefersTo:=r.Offset(0, 1)
ThisWorkbook.Names.Add Name:="amounts", RefersTo:=r.Offset(0, 2)

.Columns("A").AdvancedFilter Action:=xlFilterCopy, _
unique:=True, copytorange:=Sheets("Summary").Range("A1:a1")
End With

With ThisWorkbook.Sheets("Summary")
.Rows("1:1").NumberFormat = "dd mmm yyyy"
.Range("b1").FormulaR1C1 = _
"=date(year(min(Data!c)),1+month(min(Data!c)),day( 0))"
.Range("c1:z1").FormulaR1C1 = _
"=date(year(rc[-1]),2+month(rc[-1]),day(0))"

Set r = .Range("c1:z1")
For Each c In r
If c - 32 Application.Max(Sheets("Data").Range("dates")) Then
c.ClearContents

ElseIf c.Offset(0, -1) = "" Then c.ClearContents
End If


Next c
Set r = .Range(.Range("a2"), .Range("a" & _
Rows.Count).End(xlUp)).Offset(0, 1)

Application.Calculation = xlManual
Application.ScreenUpdating = False

r.FormulaR1C1 = _
"=sumproduct((Summary!r1c=dates)*(Customer=Summar y!rc1)*(amounts))"
Set r = .Range(.Range("b1"),
.Range("iv1").End(xlToLeft).Offset(Application.Cou ntA(.Range("a:a")) -
2, 0)).Offset(1, 0)
r.FormulaR1C1 = _
"=sumproduct((Summary!r1c=dates)*(customer=Summar y!rc1)*(amounts))-sum(Summary!rc3:rc[-1])"
.Rows("1.1").Font.Bold = True
.Columns("A:a").Font.Bold = True
.Cells.Columns.AutoFit
End With

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True

End Sub

--

Dave Peterson