Performance lag issue
 

Hi Team


I was given a workbook with approx. 100,000 rows in total which they want to draw demographics from over there network which has a hamster treadmill for speed.. :)

I actually used cell formulas to begin with and noticed two things happen:

1. the file ballooned to a an unmanageable size. ( should be a Database IMO ).
2. It literally ground to a halt the more rows I copied the formula to.

I decided to code it and came up with this and by all accounts the following does what I need it to do, albeit at a snails pace like almost 4 mins for 500 rows when I broke into the code as it was taking way too long.

In-as-much as it will most likely not make much sense without any file or data , but! I am hoping maybe you guys can see if there is a simplified approach that could turn this Model -T into a Ferrari.. lol.

As always

Many thanks in advanced.
Kind regards
Mark.

Sub Process_Me()

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Dim myWbook As Workbook
Dim myRange As Range, c As Range

Set myWbook = ThisWorkbook
Set myRange = Sheets("Data").Range("L2:L10000")

For Each c In myRange
If Not c = "" Then
With c.Offset(, 1)
.FormulaR1C1 = "=IF(RC[-3]="""","""",(RC[-3]-INT(RC[-3])))"
.Value = .Value
End With
With c.Offset(, 2)
.FormulaR1C1 = "=IF(RC[-4]="""","""",IF(OR(RC5=RC33, RC5=RC34, 1),2))"
.Value = .Value
End With
With c.Offset(, 3)
.FormulaR1C1 = "=IF(AND(RC14=2,RC13<0.25),(RC13+0.5),(RC13))"
.Value = .Value
End With
With c.Offset(, 4)
.FormulaR1C1 = "=RC15"
.Value = .Value
End With
With c.Offset(, 5)
.FormulaR1C1 = "=IF(RC11="""","""",RC11-INT(RC11))"
.Value = .Value
End With
With c.Offset(, 6)
.FormulaR1C1 = "=IF(RC15="""","""",IF(RC17RC15,RC17-RC15,RC15-RC17))"
.Value = .Value
End With
With c.Offset(, 7)
.FormulaR1C1 = "=IF(RC16="""","""",IF(RC17RC16,""LATE"",IF(RC17< RC16,""EARLY"",""ON TIME"")))"
.Value = .Value
End With
With c.Offset(, 8)
.FormulaR1C1 = "=IF(RC[-14]="""","""",IF(AND(RC19=""LATE"",(RC17-RC16<0.0208)),""ON TIME"",IF(RC17<RC16,""EARLY"",IF(RC17=RC16,""ON TIME"",""LATE""))))"
.Value = .Value
End With
With c.Offset(, 9)
.FormulaR1C1 = "=IF(RC12="""","""",TIME(HOUR(RC12),MINUTE(RC12),S ECOND(RC12)))"
.Value = .Value
End With
With c.Offset(, 10)
.FormulaR1C1 = "=IF(RC9="""","""",RC9-1)"
.Value = .Value
End With
With c.Offset(, 11)
.FormulaR1C1 = "=IF(COUNTIFS(RC11:RC11,RC11,RC8:RC8,RC8,RC17:RC17 ,RC17)=1,1,"""")"
.Value = .Value
End With
With c.Offset(, 12)
.FormulaR1C1 = "=SUMIFS(C[-15]:C[-15],C[-16]:C[-16],RC[-16],C[-13]:C[-13],RC[-13])"
.Value = .Value
End With
With c.Offset(, 13)
.FormulaR1C1 = "=IF(RC[-2]="""","""",((RC[-2]*RC[-3])-1))"
.Value = .Value
End With
With c.Offset(, 14)
.FormulaR1C1 = "=IF(RC[-3]<1,0,IF(RC[-1]24,23,RC[-1]))"
.Value = .Value
End With
With c.Offset(, 15)
.FormulaR1C1 = "=IF(RC[-1]0,15,0)"
.Value = .Value
End With
With c.Offset(, 16)
.FormulaR1C1 = "=IF(ISERROR(RC[-4]*2+RC[-1]),0,(RC[-4]*2+RC[-1]))"
.Value = .Value
End With
With c.Offset(, 17)
.FormulaR1C1 = "=IF(RC[-1]=0,0,(RC[-1]/1440))"
.Value = .Value
End With
With c.Offset(, 18)
.FormulaR1C1 = "=IF(RC[-7]<1,0,IF(RC[-14]RC[-9],0,IF(RC[-13]<RC[-14],RC[-9]-RC[-14],RC[-9]-RC[-13])))"
.Value = .Value
End With
With c.Offset(, 19)
.FormulaR1C1 = "=IF(RC[-8]<1,0,IF(RC[-1]RC[-2],0,IF(RC[-1]-RC[-2],0)))"
.Value = .Value
End With
With c.Offset(, 20)
.FormulaR1C1 = "=IF(RC12="""","""",TRIM(RC5))"
.Value = .Value
End With

Else: Exit Sub

End If
Next c

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

Performance lag issue
 

Hi Mark,

Am Tue, 13 Feb 2018 05:12:42 -0800 (PST) schrieb Living the Dream:

I actually used cell formulas to begin with and noticed two things happen:

1. the file ballooned to a an unmanageable size. ( should be a Database IMO ).
2. It literally ground to a halt the more rows I copied the formula to.


try:

Sub Process_Me()
Dim LRow As Long
Dim iCalc As Integer

With Application
.ScreenUpdating = False
.EnableEvents = False
iCalc = .Calculation
.Calculation = xlCalculationManual
End With

Dim myWbook As Workbook

Set myWbook = ThisWorkbook
With Sheets("Data")
LRow = .Cells(.Rows.Count, "L").End(xlUp).Row

With .Cells(2, 13).Resize(LRow - 1)
.Formula = "=IF(J2="""","""",(J2-INT(J2)))"
.Value = .Value
End With
With .Cells(2, 14).Resize(LRow - 1)
.Formula = "=IF(J2="""","""",IF(OR($E2=$AG2, $E2=$AH2, 1),2))"
.Value = .Value
End With
With .Cells(2, 15).Resize(LRow - 1)
.Formula = "=IF(AND($N2=2,$M2<0.25),($M2+0.5),($M2))"
.Value = .Value
End With
With .Cells(2, 16).Resize(LRow - 1)
.Formula = "=$O2"
.Value = .Value
End With
With .Cells(2, 17).Resize(LRow - 1)
.Formula = "=IF($K2="""","""",$K2-INT($K2))"
.Value = .Value
End With
With .Cells(2, 18).Resize(LRow - 1)
.Formula = "=IF($O2="""","""",IF($Q2$O2,$Q2-$O2,$O2-$Q2))"
.Value = .Value
End With
With .Cells(2, 19).Resize(LRow - 1)
.Formula = "=IF($P2="""","""",IF($Q2$P2,""LATE"",IF($Q2<$P2, ""EARLY"",""ON TIME"")))"
.Value = .Value
End With
With .Cells(2, 20).Resize(LRow - 1)
.Formula = "=IF(F2="""","""",IF(AND($S2=""LATE"",($Q2-$P2<0.0208)),""ON TIME"",IF($Q2<$P2,""EARLY"",IF($Q2=$P2,""ON TIME"",""LATE""))))"
.Value = .Value
End With
With .Cells(2, 21).Resize(LRow - 1)
.Formula = "=IF($L2="""","""",TIME(HOUR($L2),MINUTE($L2),SECO ND($L2)))"
.Value = .Value
End With
With .Cells(2, 22).Resize(LRow - 1)
.Formula = "=IF($I2="""","""",$I2-1)"
.Value = .Value
End With
With .Cells(2, 23).Resize(LRow - 1)
.Formula = "=IF(COUNTIFS($K2:$K2,$K2,$H2:$H2,$H2,$Q2:$Q2,$Q2) =1,1,"""")"
.Value = .Value
End With
With .Cells(2, 24).Resize(LRow - 1)
.Formula = "=SUMIFS(I:I,H:H,H2,K:K,K2)"
.Value = .Value
End With
With .Cells(2, 25).Resize(LRow - 1)
.Formula = "=IF(W2="""","""",((W2*V2)-1))"
.Value = .Value
End With
With .Cells(2, 26).Resize(LRow - 1)
.Formula = "=IF(W2<1,0,IF(Y224,23,Y2))"
.Value = .Value
End With
With .Cells(2, 27).Resize(LRow - 1)
.Formula = "=IF(Z20,15,0)"
.Value = .Value
End With
With .Cells(2, 28).Resize(LRow - 1)
.Formula = "=IF(ISERROR(X2*2+AA2),0,(X2*2+AA2))"
.Value = .Value
End With
With .Cells(2, 29).Resize(LRow - 1)
.Formula = "=IF(AB2=0,0,(AB2/1440))"
.Value = .Value
End With
With .Cells(2, 30).Resize(LRow - 1)
.Formula = "=IF(W2<1,0,IF(P2U2,0,IF(Q2<P2,U2-P2,U2-Q2)))"
.Value = .Value
End With
With .Cells(2, 31).Resize(LRow - 1)
.Formula = "=IF(W2<1,0,IF(AD2AC2,0,IF(AD2-AC2,0)))"
.Value = .Value
End With
With .Cells(2, 32).Resize(LRow - 1)
.Formula = "=IF($L2="""","""",TRIM($E2))"
.Value = .Value
End With
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With

End Sub


Regards
Claus B.
--
Windows10
Office 2016

Performance lag issue
 

Try this way to see if it's any faster...


Option Explicit

Sub Test()
Dim rng As Range
Set rng = Range("L2:L10000").Resize(, 21)
Application.Index(rng, 0, 2) = "=IF(RC[-3]="""","""",(RC[-3]-INT(RC[-3])))"
Application.Index(rng, 0, 3) =
"=IF(RC[-4]="""","""",IF(OR(RC5=RC33,RC5=RC34,1),2))"
Application.Index(rng, 0, 4) = "=IF(AND(RC14=2,RC13<0.25),RC13+0.5,RC13)"
Application.Index(rng, 0, 5) = "=RC15"
Application.Index(rng, 0, 6) = "=IF(RC11="""","""",RC11-INT(RC11))"
Application.Index(rng, 0, 7) =
"=IF(RC15="""","""",IF(RC17RC15,RC17-RC15,RC15-RC17))"
Application.Index(rng, 0, 8) =
"=IF(RC16="""","""",IF(RC17RC16,""LATE"",IF(RC17< RC16,""EARLY"",""ON
TIME"")))"
Application.Index(rng, 0, 9) =
"=IF(RC[-14]="""","""",IF(AND(RC19=""LATE"",(RC17-RC16<0.0208)),""ON
TIME"",IF(RC17<RC16,""EARLY"",IF(RC17=RC16,""ON TIME"",""LATE""))))"
Application.Index(rng, 0, 10) =
"=IF(RC12="""","""",TIME(HOUR(RC12),MINUTE(RC12),S ECOND(RC12)))"
Application.Index(rng, 0, 11) = "=IF(RC9="""","""",RC9-1)"
Application.Index(rng, 0, 12) =
"=IF(COUNTIFS(RC11:RC11,RC8:RC8,RC17:RC17,RC17)=1, 1,"""")"
Application.Index(rng, 0, 13) =
"=SUMIFS(C[-15]:C[-15],C[-16]:C[-16],RC[-16],C[-13]:C[-13],RC[-13])"
Application.Index(rng, 0, 14) = "=IF(RC[-2]="""","""",((RC[-2]*RC[-3])-1))"
Application.Index(rng, 0, 15) = "=IF(RC[-3]<1,0,IF(RC[-1]24,23,RC[-1]))"
Application.Index(rng, 0, 16) = "=IF(RC[-1]0,15,0)"
Application.Index(rng, 0, 17) =
"=IF(ISERROR(RC[-4]*2+RC[-1]),0,(RC[-4]*2+RC[-1]))"
Application.Index(rng, 0, 18) = "=IF(RC[-1]=0,0,(RC[-1]/1440))"
Application.Index(rng, 0, 19) =
"=IF(RC[-7]<1,0,IF(RC[-14]RC[-9],0,IF(RC[-13]<RC[-14],RC[-9]-RC[-14],RC[-9]-RC[-13])))"
Application.Index(rng, 0, 20) =
"=IF(RC[-8]<1,0,IF(RC[-1]RC[-2],0,IF(RC[-1]-RC[-2],0)))"
Application.Index(rng, 0, 21) = "=IF(RC12="""","""",TRIM(RC5))"
With Range("M2:M10000").Resize(, 20): .Value = .Value: End With
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Performance lag issue
 

To handle long procedures that have the nature to slow things down, I use this
EnableFastCode routine located in a module named "mWorkspace":

Option Explicit

Type udtAppModes
'Default types
Events As Boolean: CalcMode As XlCalculation: Display As Boolean: CallerID As
String
'Project-specific types
End Type
Public AppMode As udtAppModes

Sub EnableFastCode(Caller$, Optional SetFast As Boolean = True)
' **Note: Requires 'Type udtAppModes' and 'Public AppMode As udtAppModes'
declarations

'The following will make sure only the Caller has control,
'and allows any Caller to take control when not in use.
If AppMode.CallerID < Caller Then _
If AppMode.CallerID < "" Then Exit Sub

With Application
If SetFast Then
AppMode.Display = .ScreenUpdating: .ScreenUpdating = False
AppMode.CalcMode = .Calculation: .Calculation = xlCalculationManual
AppMode.Events = .EnableEvents: .EnableEvents = False
AppMode.CallerID = Caller
Else
.ScreenUpdating = AppMode.Display
.Calculation = AppMode.CalcMode
.EnableEvents = AppMode.Events
AppMode.CallerID = ""
End If
End With
End Sub

Once a CallerId is logged, no other procedures can 'toggle' the settings. That
ensures that your caller has control until it's done with it.


I use it like this:

Sub DoThis()
Const sSrc$ = "DoThis"
'...
'...
'...
EnableFastCode sSrc '//lockout
'lengthy processes here
EnableFastCode sSrc, False '//release
'...
'...
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Performance lag issue
 

Hi Mark,

Am Tue, 13 Feb 2018 15:50:25 +0100 schrieb Claus Busch:

Sub Process_Me()
Dim LRow As Long
Dim iCalc As Integer

ignore the previous answer.

Better try:

Sub Process_Me()
Dim LRow As Long
Dim myWbook As Workbook

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo CleanUp

Set myWbook = ThisWorkbook
With Sheets("Data")
LRow = .Cells(.Rows.Count, "L").End(xlUp).Row
.Cells(2, 13).Resize(LRow - 1).Formula = _
"=IF(J2="""","""",(J2-INT(J2)))"
.Cells(2, 14).Resize(LRow - 1).Formula = _
"=IF(J2="""","""",IF(OR($E2=$AG2, $E2=$AH2, 1),2))"
.Cells(2, 15).Resize(LRow - 1).Formula = _
"=IF(AND($N2=2,$M2<0.25),($M2+0.5),($M2))"
.Cells(2, 16).Resize(LRow - 1).Formula = "=$O2"
.Cells(2, 17).Resize(LRow - 1).Formula = _
"=IF($K2="""","""",$K2-INT($K2))"
.Cells(2, 18).Resize(LRow - 1).Formula = _
"=IF($O2="""","""",IF($Q2$O2,$Q2-$O2,$O2-$Q2))"
.Cells(2, 19).Resize(LRow - 1).Formula = _
"=IF($P2="""","""",IF($Q2$P2,""LATE"",IF($Q2<$P2, ""EARLY"",""ON TIME"")))"
.Cells(2, 20).Resize(LRow - 1).Formula = _
"=IF(F2="""","""",IF(AND($S2=""LATE"",($Q2-$P2<0.0208)),""ON
TIME"",IF($Q2<$P2,""EARLY"",IF($Q2=$P2,""ON TIME"",""LATE""))))"
.Cells(2, 21).Resize(LRow - 1).Formula = _
"=IF($L2="""","""",TIME(HOUR($L2),MINUTE($L2),SECO ND($L2)))"
.Cells(2, 22).Resize(LRow - 1).Formula = "=IF($I2="""","""",$I2-1)"
.Cells(2, 23).Resize(LRow - 1).Formula = _
"=IF(COUNTIFS($K2:$K2,$K2,$H2:$H2,$H2,$Q2:$Q2,$Q2) =1,1,"""")"
.Cells(2, 24).Resize(LRow - 1).Formula = "=SUMIFS(I:I,H:H,H2,K:K,K2)"
.Cells(2, 25).Resize(LRow - 1).Formula =
"=IF(W2="""","""",((W2*V2)-1))"
.Cells(2, 26).Resize(LRow - 1).Formula =
"=IF(W2<1,0,IF(Y224,23,Y2))"
.Cells(2, 27).Resize(LRow - 1).Formula = "=IF(Z20,15,0)"
.Cells(2, 28).Resize(LRow - 1).Formula =
"=IF(ISERROR(X2*2+AA2),0,(X2*2+AA2))"
.Cells(2, 29).Resize(LRow - 1).Formula = "=IF(AB2=0,0,(AB2/1440))"
.Cells(2, 30).Resize(LRow - 1).Formula = _
"=IF(W2<1,0,IF(P2U2,0,IF(Q2<P2,U2-P2,U2-Q2)))"
.Cells(2, 31).Resize(LRow - 1).Formula = _
"=IF(W2<1,0,IF(AD2AC2,0,IF(AD2-AC2,0)))"
.Cells(2, 32).Resize(LRow - 1).Formula =
"=IF($L2="""","""",TRIM($E2))"

CleanUp:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

With .Range("M2:AF" & LRow)
.Value = .Value
End With
End With
End Sub


Regards
Claus B.
--
Windows10
Office 2016

Performance lag issue
 

Garry & Claus

Thank you once again, you guys are amazing.

Garry

Not wanting you to feel your contribution wasn't appreciated, I "will" try your idea later when I have time; I went with Claus'code as it was quick which got me where I needed to be today.

Claus

As I have already captured the results of the original data rows in Columns A:L which is the target region where Data will get updated to each week, is there a way to skip the code so it doesn't always start at Row 2, rather start at the first newly added data that has a blank cell in Column "M".

BTW

Code took roughly 60 secs to do just under 100k rows, very neat, thank you.

Once again
Many thanks
Mark.

Performance lag issue
 

Garry & Claus

Thank you once again, you guys are amazing.

Garry

Not wanting you to feel your contribution wasn't appreciated, I "will" try
your idea later when I have time; I went with Claus'code as it was quick
which got me where I needed to be today.

Enjoy!

Claus

As I have already captured the results of the original data rows in Columns
A:L which is the target region where Data will get updated to each week, is
there a way to skip the code so it doesn't always start at Row 2, rather
start at the first newly added data that has a blank cell in Column "M".

BTW

Code took roughly 60 secs to do just under 100k rows, very neat, thank you.

Once again
Many thanks
Mark.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Performance lag issue
 

Code took roughly 60 secs to do just under 100k rows, very neat, thank you.

FYI
Took mine less than 2 secs to do 10K rows, 20 cols!

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion