shamsam1
08-28-2008, 02:46 AM
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"),Range("k13:k150")
I need to run:friends: my code bit fast....
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
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.
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"),Range("k13:k150")
I need to run:friends: my code bit fast....
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
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.