PDA

View Full Version : Speed up a slow code



copyt
05-16-2012, 10:47 PM
Hello all, I have a code that I need to use over 500 times a day. My code is quite slow so I hope somebody could help/suggest me to speed it up. Anyhelp would be appreciated.





Sub CheckIndepentPeaks()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim finalrowPepA As Long
Dim finalrowPepB As Long
Dim x As Long
Dim y As Long
Dim i As Long
Dim j As Long
Dim MSMStol As Single
Dim lngPasteRow As Long
Dim finalrow As Long


MSMStol = Sheets("Parameters").cells(7, 2).Value
finalrowPepA = cells(Rows.Count, 14).End(xlUp).Row
finalrowPepB = cells(Rows.Count, 21).End(xlUp).Row

If finalrowPepA >= finalrowPepB Then finalrow = finalrowPepA Else finalrow = finalrowPepB


For x = 13 To finalrow
For y = 11 To 31
If (y <> 14 And y <> 21 And y <= 24) Or (y >= 27 And x = 14) Then
For i = x To finalrow
For j = y To 31
If (j <> 14 And j <> 21 And j <= 24) Or (j >= 27 And i = 14) Then
If i <> x Or j <> y Then
If cells(x, y) + MSMStol >= cells(i, j) And cells(x, y) - MSMStol <= cells(i, j) Then

cells(x, y).Font.ColorIndex = 17
cells(i, j).Font.ColorIndex = 17

End If
End If
End If
Next j
Next i
End If
Next y
Next x

Application.EnableEvents = True

End Sub

Bob Phillips
05-17-2012, 12:35 AM
The nested loops are definitely the issue, and it will need a re-design. It is hard to suggest anything without knowing what you are trying to do. Can you explain what the code does in English, business, terms, preferably with an example workbook.

copyt
05-17-2012, 01:06 AM
@ xld,

Thanks for your response. The code is looking for the numeric data
that are almost duplicate then give a color to those matches.

The error(+/-) for matching is assigned as "MSMStol".

Column 11-13, 15-20, 22-24, 27-31 are the area for matching. For column 27-31, only row 14 is taken in to account.

Thanks,

Bob Phillips
05-17-2012, 02:06 AM
Can you give me more detail on how the matches are identified. I can probably work it out from the code, but an explanation will save me time.

p45cal
05-17-2012, 02:18 AM
This seems to about halve the time. I think sheet reads/writes could be adding to the processing time. If I get time, I'll look at doing most of it in memory and keeping reads and writes to the sheet to a minimum.Sub blah()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim cll As Range, celle As Range
MSMStol = Sheets("Parameters").Cells(7, 2).Value
finalrow = Application.Max(Cells(Rows.Count, 14).End(xlUp).Row, Cells(Rows.Count, 21).End(xlUp).Row)
Set myrng = Intersect(Rows("13:" & finalrow), Union(Range("K:M,O:T,V:X"), Range("AA14:AE14")))
'myrng.Select
'myrng.Font.ColorIndex = xlAutomatic
'myrng.Font.Bold = False
For Each cll In myrng.Cells
'cll.Select
Set myrng2 = Intersect(myrng, Rows(cll.Row & ":" & finalrow), Range(Columns(cll.Column), Columns(31)))
'myrng2.Select
For Each celle In myrng2.Cells
If cll.Address <> celle.Address Then
stick = cll.Value 'sorry about crass naming of variables!
myMin = stick - MSMStol
myMax = stick + MSMStol
myVar = celle.Value
If myVar <= myMax And myVar >= myMin Then
cll.Font.ColorIndex = 17
celle.Font.ColorIndex = 17
'cll.Font.Bold = True
'celle.Font.Bold = True
End If
End If
Next celle
Next cll
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
End Sub

copyt
05-17-2012, 02:23 AM
@ xld,

For example, A and B are the value in the cells and
the error for matching is from -0.1 to 0.1.

If A + 0.1 >= B and A - 0.1 <= B, so I expect that A and B are almost the same value.

copyt
05-17-2012, 02:36 AM
@ (http://www.vbaexpress.com/forum/member.php?u=3494)p45cal (http://www.vbaexpress.com/forum/member.php?u=3494)

Thanks for the code. It works like a charm :cloud9:

Bob Phillips
05-17-2012, 02:44 AM
@ (http://www.vbaexpress.com/forum/member.php?u=3494)p45cal (http://www.vbaexpress.com/forum/member.php?u=3494)

Thanks for the code. It works like a charm :cloud9:


I couldn't see any checking of columns in that code. Does it just work for that sample, or would another fail because it doesn't do that check?

p45cal
05-17-2012, 02:44 AM
I hadn't seen your attached file before I posted last. Now that I've looked at that file and tried my code against yours, I get different shading!

copyt
05-17-2012, 02:53 AM
The code I posted and the code in the example file are a bit different.

The one in the example file I just saw the error so I corrected it.

Thanks,

copyt
05-17-2012, 03:09 AM
@ p45cal, I change

Set myrng2 = Intersect(myrng, Rows(cll.Row & ":" & finalrow), Range(Columns(cll.Column), Columns(31)))




to

Set myrng2 = Intersect(myrng, Rows("13:" & finalrow), Range(Columns(cll.Column), Columns(31)))

And I would like to thank both of you again for responses and kind helps :bow::bow::bow:

p45cal
05-17-2012, 04:09 AM
@ p45cal, I change

Set myrng2 = Intersect(myrng, Rows(cll.Row & ":" & finalrow), Range(Columns(cll.Column), Columns(31)))



to

Set myrng2 = Intersect(myrng, Rows("13:" & finalrow), Range(Columns(cll.Column), Columns(31)))
In that case, change it to the simpler:Set myrng2 = Intersect(myrng, Range(Columns(cll.Column), Columns(31)))

p45cal
05-17-2012, 05:33 AM
Just to show how doing things in memory speeds things up, minor tweaking of your original code gives a more than tenfold increase in speed:
Sub CheckIndepentPeaks2()
ActiveSheet.DisplayPageBreaks = False
'no need to disable calculation, screenupdating etc.
Dim finalrowPepA As Long
Dim finalrowPepB As Long
Dim x As Long
Dim y As Long
Dim i As Long
Dim j As Long
Dim MSMStol As Single
Dim lngPasteRow As Long
Dim finalrow As Long
Dim myrng As Range, newrng As Range

MSMStol = 0.1
finalrowPepA = Cells(Rows.Count, 14).End(xlUp).Row
finalrowPepB = Cells(Rows.Count, 21).End(xlUp).Row

If finalrowPepA >= finalrowPepB Then finalrow = finalrowPepA Else finalrow = finalrowPepB
Set myrng = Range("A1:AE" & finalrow)
rng = myrng.Value
For x = 13 To finalrow
For y = 11 To 31
If (y <> 14 And y <> 21 And y <= 24) Or (y >= 27 And x = 14) Then
For i = 13 To finalrow
For j = 13 To 31
If (j <> 14 And j <> 21 And j <= 24) Or (j >= 27 And i = 14) Then
If i <> x Or j <> y Then
If (rng(x, y) <> Empty) And (rng(i, j) <> Empty) Then
If rng(x, y) + MSMStol >= rng(i, j) And rng(x, y) - MSMStol <= rng(i, j) Then
Set newrng = Union(IIf(newrng Is Nothing, myrng(x, y), newrng), myrng(x, y), myrng(i, j))
End If
End If
End If
End If
Next j
Next i
End If
Next y
Next x
newrng.Font.ColorIndex = 17
End Sub

copyt
05-17-2012, 12:21 PM
@p45cal (http://www.vbaexpress.com/forum/member.php?u=3494),

Thanks for the example code. So I will apply to the other codes as well.

snb
05-17-2012, 01:48 PM
I would use:

Sub snb()
sn = Sheets("msmscal").Cells(13, 11).CurrentRegion.Resize(, 17)

For j = 1 To UBound(sn)
For jj = 1 To 11
y=Choose(jj, 3, 5, 6, 7, 8, 9, 10, 12, 13, 14, 17)
If sn(j, 1) => sn(j, y) - 0.1 And sn(j, 1) <= sn(j, y) + 0.1 Then c01 = c01 & "," & Cells(j + 12, y + 10).Address
Next
Next

For Each cl In Split(Mid(c01, 2), ",")
Range(cl).Interior.ColorIndex = 3
If Range(cl).Column = 27 And Range(cl).Row <> 14 Then Range(cl).Interior.ColorIndex = Range("A1").Interior.ColorIndex
Next
End Sub

NB. You still have to check whether I do the comparison like you want to.