Hi Beckham,

Just trying the code, found there has an error ,

I set the break point to " Set w=ThisWorkbook.sheets("summary")", the
error is
"Run time error 1004" Apllication-defined or object-defined error ??

It should be related the NEXT C and before the set statment but I do
not have idea what's the problem could you help me again.

Thanks



(dolphin_ty) wrote in message . com...
I want to thank you both before trial the suggestion. I'm not familiar
with excel programmming so need sometime to digest.

May need your help again, thanks for kind advice.




"Kevin Beckham" wrote in message ...
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
.