Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
return values rather than formula.
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.Co untA(.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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
return values rather than formula.
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
return values rather than formula.
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 . |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 . |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
return values rather than formula.
|
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
formula to return value from a matrix - I know hor and vert values | Excel Worksheet Functions | |||
creating formula to return one of several values | Excel Worksheet Functions | |||
Excel formula to return all non-blank values | Excel Discussion (Misc queries) | |||
Need a formula to look up 2 values and return result from 3rd colu | Excel Worksheet Functions | |||
conditional formula: return 1 of 4 values | Excel Worksheet Functions |