I have a much faster computer and the following code
appears to run in 3-4 seconds for 3000 records.

Sub ConsolidateReport()
Dim DataTable As Range
Dim Users As Range
Dim Items As Range
Dim rDates As Range
Dim c As Range
Dim qty() As Long
Dim noUser As Integer
Dim noItem As Integer
Dim noDate As Integer

Dim w As Worksheet

BuildTables DataTable, Users, Items, rDates

ReDim qty(Users.Rows.Count, Items.Rows.Count,
rDates.Rows.Count)

For Each c In DataTable.Offset(1, 0).Resize
(DataTable.Rows.Count - 1, 1)
noUser = Application.WorksheetFunction.Match
(c.Value, Users)
noItem = Application.WorksheetFunction.Match
(c.Offset(0, 1).Value, Items)
noDate = Application.WorksheetFunction.Match(CLng
(c.Offset(0, 2).Value), rDates)
If qty(noUser, noItem, 0) = 0 Then qty(noUser,
noItem, 0) = 1
qty(noUser, noItem, noDate) = qty(noUser, noItem,
noDate) + c.Offset(0, 3)
Next c

Set w = ThisWorkbook.Sheets("Summary")

rDates.Copy
w.Cells(1, 3).PasteSpecial xlPasteAll, Transpose:=True
Set c = w.Cells(2, 2)

For noUser = 1 To Users.Rows.Count
For noItem = 1 To Items.Rows.Count
If qty(noUser, noItem, 0) < 0 Then
c.Offset(0, -1).Value = Users.Offset
(noUser - 1, 0).Resize(1, 1)
c.Value = Items.Offset(noItem - 1,
0).Resize(1, 1)
For noDate = 1 To rDates.Rows.Count
If qty(noUser, noItem, noDate) 0
Then c.Offset(0, noDate) = qty(noUser, noItem, noDate)
Next noDate
Set c = c.Offset(1, 0)
End If
Next noItem

Next noUser

End Sub

Sub BuildTables(r As Range, Users As Range, Items As
Range, Dates As Range)
Dim sDate As Date
Dim fDate As Date
Dim n As Integer

ThisWorkbook.Sheets("Data").Activate

Set r = Range("A1", Range("A1").End(xlDown))

With Range("A1:B1")
.Copy .Offset(0, 8)
.Offset(1, 8).Formula = """ """
End With

With Range("A1")
r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=
_
.Offset(0, 8).Resize(2, 1), CopyToRange:=.Offset
(4, 8), Unique:=True
End With
With Range("A1").Offset(4, 8)
Range(.Offset(1, 0), .End(xlDown)).Sort .Offset(1, 0),
xlAscending
Set Users = Range(.Offset(1, 0), .End(xlDown))
End With

With Range("B1")
r.Offset(0, 1).AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:= _
.Offset(0, 8).Resize(2, 1), CopyToRange:=.Offset
(4, 8), Unique:=True
End With
With Range("B1").Offset(4, 8)
Range(.Offset(1, 0), .End(xlDown)).Sort .Offset(1, 0),
xlAscending
Set Items = Range(.Offset(1, 0), .End(xlDown))
End With

sDate = Application.WorksheetFunction.Min(r.Offset(0,
2))
fDate = Application.WorksheetFunction.Max(r.Offset(0,
2))
sDate = DateSerial(Year(sDate), Month(sDate), 1)
If Month(fDate) = 12 Then
fDate = DateSerial(Year(fDate), Month(fDate), 31)
Else
fDate = DateSerial(Year(fDate), Month(fDate) + 1,
1) - 1
End If
With Range("C1").Offset(4, 8)
.Value = "date"
.Offset(1, 0) = sDate
n = 1
Do While .Offset(n, 0) < fDate
If Month(.Offset(n, 0)) = 12 Then
.Offset(n + 1, 0) = DateSerial(Year(.Offset(n,
0)) + 1, 1, 1)
Else
.Offset(n + 1, 0) = DateSerial(Year(.Offset(n,
0)), Month(.Offset(n, 0)) + 1, 1)
End If
n = n + 1
Loop

Set Dates = Range(.Offset(1, 0), .End(xlDown))
End With

End Sub


Kevin Beckham

-----Original Message-----
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.ClearContent s

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=Summa ry!rc1)*
(amounts))"
Set r = .Range(.Range("b1"),
..Range("iv1").End(xlToLeft).Offset(Application.C ountA
(.Range("a:a")) -
2, 0)).Offset(1, 0)
r.FormulaR1C1 = _
"=sumproduct((Summary!r1c=dates)*(customer=Summa ry!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
.