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