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 |
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 . |
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 . |
return values rather than formula.
|
return values rather than formula.
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 (dolphin_ty) wrote in message . com... 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. |
All times are GMT +1. The time now is 03:16 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com