SPC 判异
Sub AutoJudge() Dim avera As Double Dim sigma As Double Dim UCLx As Double Dim LCLx As Double Dim temOver As Long Dim temSameSide As Long Dim temUpOrDown As Long Dim temUpAndDown As Long Dim tem2Of3 As Long Dim tem4Of5 As Long Dim tem15sigma As Long Dim tem8sigma As Long Dim temRang As Range Dim temR As Range Dim maxColumn As Long Dim temArr() Dim temData2Of3() Dim temData4Of5() Dim temPriData As Double Dim temPriDeiva As Double Set temRang = Range(Cells(8, 4), Cells(8, 62)) If temRang.Rows.Count > 1 Then MsgBox "Please select only one row range for SPC judgemnt." Exit Sub End If UCLx = -0.813612221 LCLx = -1.136132694 avera = -0.974872458 sigma = WorksheetFunction.Min((UCLx - avera) / 3, (avera - LCLx) / 3) temOver = 3 temSameSide = 7 temUpOrDown = 6 temUpAndDown = 14 tem2Of3 = 3 tem4Of5 = 5 tem15sigma = 15 tem8sigma = 8 maxColumn = 100 countOver = 0 countSameSide = 0 countUpOrDown = 0 countUpAndDown = 0 count2Of3 = 0 count4Of5 = 0 count15sigma = 0 count8sigma = 0 ReDim temData2Of3(1 To tem2Of3, 1 To 2) For i = 1 To UBound(temData2Of3) temData2Of3(i, 1) = 0 temData2Of3(i, 2) = 0 Next ReDim temData4Of5(1 To tem4Of5, 1 To 2) For i = 1 To UBound(temData4Of5) temData4Of5(i, 1) = 0 temData4Of5(i, 2) = 0 Next temPriData = 0 temPriDeiva = 0 If temRang.Columns.Count > maxColumn Then Set temRang = Range(Cells(temRang.Row, temRang.Column + temRang.Columns.Count - maxColumn), Cells(temRang.Row, temRang.Column + temRang.Columns.Count - 1)) temRang.Select Else maxColumn = temRang.Columns.Count End If temArr = Application.Transpose(temRang) For i = 1 To UBound(temArr) temV = temArr(i, 1) - avera 'Over control limit If temV > UCLx - avera Or temV < LCLx - avera Then countOver = countOver + 1 Else countOver = 0 End If If countOver >= temOver Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 countOver = countOver - 1 End If '7 points on the same side If temPriData * temV > 0 Then countSameSide = countSameSide + 1 Else countSameSide = 0 End If If countSameSide >= temSameSide - 1 Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 countSameSide = countSameSide - 1 End If '6 points up or down If (temPriData - temV) * temPriDeiva > 0 Then countUpOrDown = countUpOrDown + 1 Else countUpOrDown = 0 End If If countUpOrDown >= temUpOrDown - 2 Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 countUpOrDown = countUpOrDown - 1 End If temPriDeiva = (temPriData - temV) ' if 14 points up and down selected, cancel this sentence '14 points up and down If (temPriData - temV) * temPriDeiva < 0 Then countUpAndDown = countUpAndDown + 1 Else countUpAndDown = 0 End If If countUpAndDown >= temUpAndDown - 2 Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 countUpAndDown = countUpAndDown - 1 End If temPriDeiva = (temPriData - temV) '2 of 3 points over 2 sigma on same side If i < tem2Of3 Then temData2Of3(i, 1) = temV temData2Of3(i, 2) = i Else temData2Of3(tem2Of3, 1) = temV temData2Of3(tem2Of3, 2) = i End If count2Of3 = JudgeXofY(temData2Of3, 2 * sigma, 2, i) If count2Of3 > 0 Then Cells(temRang.Row, temRang.Column + count2Of3 - 1).Interior.Color = 255 End If '4 of 5 points over 1 sigma on same side If i < tem4Of5 Then temData4Of5(i, 1) = temV temData4Of5(i, 2) = i Else temData4Of5(tem4Of5, 1) = temV temData4Of5(tem4Of5, 2) = i End If count4Of5 = JudgeXofY(temData4Of5, sigma, 4, i) If count4Of5 > 0 Then Cells(temRang.Row, temRang.Column + count4Of5 - 1).Interior.Color = 255 End If '15 points within 1 sigma If Abs(temV) < sigma Then count15sigma = count15sigma + 1 Else count15sigma = 0 End If If count15sigma >= tem15sigma Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 count15sigma = count15sigma - 1 End If '8 points over 1 sigma If Abs(temV) > sigma Then count8sigma = count8sigma + 1 Else count8sigma = 0 End If If count8sigma >= tem8sigma Then Cells(temRang.Row, temRang.Column + i - 1).Interior.Color = 255 count8sigma = count8sigma - 1 End If temPriData = temV Next End Sub Function JudgeXofY(temArr, temCrite, temLong, currentAdd) Dim LowArr() Dim UpArr() temLow = 0 temUp = 0 coLow = 0 coUp = 0 JudgeXofY = 0 For i = 1 To UBound(temArr) If temArr(i, 1) - Abs(temCrite) > 0 Then temUp = temUp + 1 coUp = temArr(i, 2) ElseIf temArr(i, 1) + Abs(temCrite) < 0 Then temLow = temLow + 1 coLow = temArr(i, 2) End If If i < UBound(temArr) And UBound(temArr) <= currentAdd Then temArr(i, 1) = temArr(i + 1, 1) temArr(i, 2) = temArr(i + 1, 2) End If Next If temUp >= temLong Then JudgeXofY = coUp ElseIf temLow >= temLong Then JudgeXofY = coLow Else JudgeXofY = 0 End If End Function