return values rather than formula.
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
.
|