return values rather than formula.

D

dolphin_ty

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

Dave Peterson

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 said:
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=Summary!rc1)*(amounts))"
Set r = .Range(.Range("b1"),
.Range("iv1").End(xlToLeft).Offset(Application.CountA(.Range("a:a")) -
2, 0)).Offset(1, 0)
r.FormulaR1C1 = _
"=sumproduct((Summary!r1c>=dates)*(customer=Summary!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
Click to expand...
 
K

Kevin Beckham

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

dolphin_ty

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 said:
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.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=Summary!rc1)* (amounts))"
Set r = .Range(.Range("b1"),
..Range("iv1").End(xlToLeft).Offset(Application.CountA (.Range("a:a")) -
2, 0)).Offset(1, 0)
r.FormulaR1C1 = _
"=sumproduct((Summary!r1c>=dates)*(customer=Summary!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
.
Click to expand...
Click to expand...
 
D

dolphin_ty

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



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 said:
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.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=Summary!rc1)* (amounts))"
Set r = .Range(.Range("b1"),
..Range("iv1").End(xlToLeft).Offset(Application.CountA (.Range("a:a")) -
2, 0)).Offset(1, 0)
r.FormulaR1C1 = _
"=sumproduct((Summary!r1c>=dates)*(customer=Summary!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
.
Click to expand...
Click to expand...
Click to expand...
 
D

dolphin_ty

Hi Kevin,

I fix the problem caused some setting, I'm really gratful for the
fabulous coding from you it work for my application very much with
minor change.

Thanks again and Happy new year 2004.
Dolphin
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Loop Repeats - PLS HELP 2
VLookup in VBA Help Needed 9
Copy row info but not in normal column sequence 6
Can't find bug because program justs Stops !! 3
Object variable or with Block variable not set 9
Issue with Solver 3
How to hide password? 1
My Never ending ARRAY code problems 18

Top