Solved: Help to imrove the coding

[shamsam1]

i have code Private Sub Worksheet_SelectionChange(ByVal Target As Range)

so when i click on sheet work sheet becomes to slow to work with

in coding i am checking for max value,min value,cpk value,and standard deviation
for the above ranges ia m using this code
Range("g13:g150"),Range("h13:h150"),Range("i13:i150"),Range("j13:j150"),Ran ge("k13:k150")

I need to run my code bit fast....


[vba]Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim CurCell1 As Object
Dim CurCell2 As Object
Dim CurCell3 As Object
Dim rng As Range
Dim CurCell14 As Object
Dim WorkRange As Range
Dim MaxVal As Double
Dim cpk As Double


Dim a1 As Object, a2 As Object, a3 As Object, a4 As Object, a5 As Object, a6 As Object, a7 As Object
Dim a8 As Object
Dim a As Double
Dim b As Double, c As Double, d As Double, e As Double, f As Double, g As Double, h As Double
Dim kmax As Double, kmin As Double

Dim wSheet As Worksheet


On Error GoTo ErrHandler:
Dim ii As Integer
ii = 13

For Each CurCell1 In Range("g13:g150")
a = CDbl(CurCell1.Offset(0, -4).Value) + CDbl(CurCell1.Offset(0, -3).Value)
b = CDbl(CurCell1.Offset(0, -4).Value) - CDbl(CurCell1.Offset(0, -2).Value)

If (CurCell1.Value) <> "" Then
If (CurCell1.Value) >= b And (CurCell1.Value) <= a Then
CurCell1.Interior.ColorIndex = 10
ElseIf (CurCell1.Value) <= b Or (CurCell1.Value) >= a Then
CurCell1.Interior.ColorIndex = 3
End If
ElseIf (CurCell1.Value) = "" Then
CurCell1.Interior.ColorIndex = nofill
End If

If (CurCell1.Value) <> "" Then
Set CurCell2 = ActiveSheet.Cells(ii, 13)
CurCell2 = ""
Dim cd As String
Set CurCell2 = ActiveSheet.Cells(ii, 13)
MaxVal = (Application.Max(CDbl(Cells(ii, 7)), CDbl(Cells(ii, 8)), CDbl(Cells(ii, 9)), CDbl(Cells(ii, 10)), CDbl(Cells(ii, 11))))
If (a >= MaxVal) Then
CurCell2.Value = "PASS"
CurCell2.Interior.ColorIndex = 10
Else
CurCell2.Value = "FAIL"
CurCell2.Interior.ColorIndex = 3
End If
End If

If (CurCell1.Value) <> "" Then
Set CurCell3 = ActiveSheet.Cells(ii, 14)
CurCell3 = ""
Set CurCell3 = ActiveSheet.Cells(ii, 14)
If (CurCell3.Value) = "" Then
CurCell3.Interior.ColorIndex = nofill
End If
Set rng = Range(Cells(ii, 7), Cells(ii, 11))
MinVal = ActiveSheet.Evaluate("MIN(IF(" & rng.Address(False, False) & _
"<>0,--(" & rng.Address(False, False) & ")))")
If (b <= MinVal) Then
CurCell3.Value = "PASS"
CurCell3.Interior.ColorIndex = 10
Else
CurCell3.Value = "FAIL"
CurCell3.Interior.ColorIndex = 3
End If
End If

If (CurCell1.Value) <> "" Then
Set CurCell10 = ActiveSheet.Cells(ii, 12)
CurCell10 = ""
Set CurCell0 = ActiveSheet.Cells(ii, 12)
std = (Application.StDev(CDbl(Cells(ii, 7)), CDbl(Cells(ii, 8)), CDbl(Cells(ii, 9)), CDbl(Cells(ii, 10)), CDbl(Cells(ii, 11))))
CurCell0.Value = (std)
End If

If (CurCell1.Value) <> "" Then
'Dim cpk As Double
Set CurCell14 = ActiveSheet.Cells(ii, 15)
CurCell14 = ""
Set CurCell14 = ActiveSheet.Cells(ii, 15)
cpk = (((a - (a + b / 2) / 3 * std)))
CurCell14.Value = (Application.Min(cpk))
End If

Set a1 = ActiveSheet.Cells(ii, 3)
Set a2 = ActiveSheet.Cells(ii, 4)
Set a3 = ActiveSheet.Cells(ii, 5)
Set a4 = ActiveSheet.Cells(ii, 7)
Set a5 = ActiveSheet.Cells(ii, 8)
Set a6 = ActiveSheet.Cells(ii, 9)
Set a7 = ActiveSheet.Cells(ii, 10)
Set a8 = ActiveSheet.Cells(ii, 11)
If ((a1.Value)) = "" And (a2.Value) = "" And (a3.Value) = "" Then
If (a4.Value) = "" And (a5.Value) = "" And (a6.Value) = "" And (a7.Value) = "" And (a8.Value) = "" Then
Range(Cells(ii, 12), Cells(ii, 15)).ClearContents
Range(Cells(ii, 12), Cells(ii, 15)).Interior.ColorIndex = nofill
End If
ElseIf ((a1.Value)) <> "" Or (a2.Value) <> "" Or (a3.Value) <> "" Then
If (a4.Value) = "" And (a5.Value) = "" And (a6.Value) = "" And (a7.Value) = "" And (a8.Value) = "" Then
Range(Cells(ii, 12), Cells(ii, 15)).ClearContents
Range(Cells(ii, 12), Cells(ii, 15)).Interior.ColorIndex = nofill
End If
End If

ii = ii + 1
Next[/vba]

Edited by Aussiebear: shamsam1, when posting code to the forum please wrap your code by using the VBA button (9th button above input box). It makes code so much easier to read.

[rbrhodes]

Hi shamsam1,

Your code repeats the check for a blank cell, etc. Try this on a COPY of your workbook. It looks to see if the selection is within Cells G13 to K150 and runs if true. Then it checks ONCE for blank value and does code only if not blank...etc.


[VBA]
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim ii As Long
Dim rng As Range
Dim cpk As Double
Dim std As Double
Dim MaxVal As Double
Dim MinVal As Double
Dim WorkRange As Range
Dim CurCell0 As Object
Dim CurCell1 As Object
Dim CurCell2 As Object
Dim CurCell3 As Object
Dim CurCell4 As Object
Dim wSheet As Worksheet
Dim a As Double, b As Double
Dim kmax As Double, kmin As Double
Dim a4 As Object, a5 As Object, a6 As Object, a7 As Object, a8 As Object

'//Check if in range, exit if not
If Intersect(Target, Range("G13:K150")) Is Nothing Then Exit Sub

On Error GoTo ErrHandler:

ii = 13


For Each CurCell1 In Range(Cells(13, Target.Column), Cells(150, Target.Column))

'//Check for blank cell only once. DO NOT REPEAT CHECK
If CurCell1.Value <> "" Then
With CurCell1
a = CDbl(.Offset(0, -4).Value) + CDbl(.Offset(0, -3).Value)
b = CDbl(.Offset(0, -4).Value) - CDbl(.Offset(0, -2).Value)

If .Value >= b And .Value <= a Then
.Interior.ColorIndex = 10
Else 'Must be different
.Interior.ColorIndex = 3
End If
End With

Set CurCell2 = Cells(ii, 13)

MaxVal = (Application.Max(CDbl(Cells(ii, 7)), CDbl(Cells(ii, 8)), CDbl(Cells(ii, 9)), CDbl(Cells(ii, 10)), CDbl(Cells(ii, 11))))

With CurCell2
If a >= MaxVal Then
.Value = "PASS"
.Interior.ColorIndex = 10
Else
.Value = "FAIL"
.Interior.ColorIndex = 3
End If
End With

Set CurCell3 = Cells(ii, 14)

With CurCell3
If .Value = "" Then
.Interior.ColorIndex = 0
End If

Set rng = Range(Cells(ii, 7), Cells(ii, 11))

MinVal = Evaluate("MIN(IF(" & rng.Address(False, False) & _
"<>0,--(" & rng.Address(False, False) & ")))")

If (b <= MinVal) Then
.Value = "PASS"
.Interior.ColorIndex = 10
Else
.Value = "FAIL"
.Interior.ColorIndex = 3
End If

End With

Set CurCell0 = Cells(ii, 12)

std = (Application.StDev(CDbl(Cells(ii, 7)), CDbl(Cells(ii, 8)), CDbl(Cells(ii, 9)), CDbl(Cells(ii, 10)), CDbl(Cells(ii, 11))))

CurCell0.Value = (std)

Set CurCell4 = Cells(ii, 15)

cpk = (((a - (a + b / 2) / 3 * std)))

CurCell4.Value = (Application.Min(cpk))

Set a4 = Cells(ii, 7)
Set a5 = Cells(ii, 8)
Set a6 = Cells(ii, 9)
Set a7 = Cells(ii, 10)
Set a8 = Cells(ii, 11)
'//Does same thing!!

If (a4.Value) = "" And (a5.Value) = "" And (a6.Value) = "" And (a7.Value) = "" And (a8.Value) = "" Then
Range(Cells(ii, 12), Cells(ii, 15)).ClearContents
Range(Cells(ii, 12), Cells(ii, 15)).Interior.ColorIndex = 0
End If

ii = ii + 1
Else 'Current cell was blank
CurCell1.Interior.ColorIndex = 0
End If
Next

ErrHandler:
'something here...

End Sub

[/VBA]

[rbrhodes]

Hmmn,

Just occured to me that you may be trying to have this run on a CHANGE in the sheet... That would be a slightly different animal.

[mdmackillop]

Hi Shamsam,
Please use Option Explicit and declare ALL variables.
Regards
MD

[shamsam1]

thanks for all the help...
will be improving on my code