Option Base 1
Option Explicit

'matX1z2z񂩃Z͈͂variant^łāC̒element܂܂ĂȂCTrueԂ
Private Function isExistS(matX, element) As Boolean
With WorksheetFunction
    On Error GoTo Err:
        If Not .IsError(.Match(element, matX, 0)) Then
            isExistS = True
            Exit Function
        Else
            isExistS = False
            Exit Function
        End If
    On Error GoTo 0
    Exit Function
Err:
    isExistS = False
End With
End Function

'y萔X0ŏdADExcel Linest֐pDExcelƂ͈ႢȏʂɗxNgŕԂ
Function OLSE(y, X0)
With WorksheetFunction
    Dim bhatByExcel, k, i, bhat
    
    bhatByExcel = .LinEst(y, X0)
    k = UBound(bhatByExcel)
    '1zbhatByExcelCxNgċtɂ
    ReDim bhat(k, 1)
    For i = 0 To k - 1
        bhat(1 + i, 1) = bhatByExcel(k - i)
    Next
    OLSE = bhat
End With
End Function

'I͈͂ŏdȂTrue
Private Function isUniqueRng(rngX) As Boolean
    Dim element

    On Error GoTo Err
    For Each element In rngX
        If WorksheetFunction.CountIf(rngX, element) > 1 Then
            isUniqueRng = False
            Exit Function
        End If
    Next
    On Error GoTo 0
    
    isUniqueRng = True
    Exit Function
    
Err:
    isUniqueRng = False
End Function

'2019ȑOłunique֐Ȃ̂ō쐬DɏdȂTrue
Private Function isUnique(ary) As Boolean
    Dim pivot, i, checkVal
    
    'Ubound(ary)ɃG[oȂC̑aryZ͈͂̂߁D̂ƂisUniqueRng֐𗘗p
    On Error GoTo Err0
        checkVal = UBound(ary)
    On Error Resume Next

    'ȍ~ary1z
    On Error GoTo Err1
        For pivot = 1 To UBound(ary)
            For i = pivot + 1 To UBound(ary)
                If ary(i) = ary(pivot) Then
                    isUnique = False
                    Exit Function
                End If
            Next
        Next
    On Error GoTo 0
    
    isUnique = True
    Exit Function

Err0:
    isUnique = isUniqueRng(ary)
    Exit Function
Err1:
    isUnique = False
End Function

'ary̐SminValueȏmaxValueȉ̐ȂCTrueԂ
Private Function isIntegerInRange(ary, minValue, maxValue) As Boolean
    Dim element
    
    On Error GoTo Err:
        For Each element In ary
            If element < minValue Or element > maxValue Or Int(element) <> element Then
                isIntegerInRange = False
                Exit Function
            End If
        Next
    On Error GoTo 0
    
    isIntegerInRange = True
    Exit Function
Err:
    isIntegerInRange = False
End Function

'Fzgϐ𗎂ƂFD3ȍ~ɁC2̉ڂ𗎂ƂĂD
Function OLSdropVarsFtest(rngY, rngX0, ParamArray paramDropColumnNumberS())
With WorksheetFunction
    Dim y, X0, n, k0, k, J
    Dim olsResult0, olsResult1
    Dim aryDropColumnS, colX0, colX1
    Dim ssResidual0, ssResidual1, fNume, fDenom, fValue, pValue
    Dim strFvalue, strDf, strPvalue
    Dim i
    'y,n,k,JOLŜ̂ƓDX0͒萔̂ȂϐsD
    y = rngY.Value
    X0 = rngX0.Value
    n = UBound(X0, 1)
    k0 = UBound(X0, 2)
    k = k0 + 1
    J = UBound(paramDropColumnNumberS) + 1
    
    If J <= 0 Then
        OLSdropVarsFtest = "error:3ȍ~ɁCϐ痎Ƃϐ̗ԍ̐Ăx"
        Exit Function
    ElseIf J > k0 Then
        OLSdropVarsFtest = "error:3ȍ~ɏϐ̗ԍ̐̌́CSX̗񐔈ȉɂĂx"
        Exit Function
    End If
        
    't̉A͂s߂ɁCƂ̐z
    'dropColumnNumberS̔z͏0X^[gȂ̂ł̕\ƂȂD
    ReDim aryDropColumnS(J)
    For i = 0 To J - 1
        aryDropColumnS(1 + i) = paramDropColumnNumberS(i)
    Next
    'G[`FbN
    If Not isIntegerInRange(aryDropColumnS, 1, k0) Then
        OLSdropVarsFtest = "error:3ȍ~ɂ́CSĐϐ痎Ƃϐ̗ԍ̐Ăx"
        Exit Function
    End If
    If Not isUnique(aryDropColumnS) Then
        OLSdropVarsFtest = "error:3ȍ~ɁCd܂DύXĂx"
        Exit Function
    End If
        
    'Ȃ̉A͂̎c
    olsResult0 = OLSEst3aryS(y, X0)
    ssResidual0 = .SumSq(olsResult0(3))
        
    '񂠂̉A͂̎c
    'Jk0̏ꍇ́Cc͑ϓŁCJ<k0̂Ƃ͐t̉Ac쐬
    If J = k0 Then
        ssResidual1 = .DevSq(y)
    Else
        'X0Cw肳ꂽ𗎂ƂX1
        ReDim X1(n, k0 - J)
        colX1 = 1
        For colX0 = 1 To k0
            If Not isExistS(aryDropColumnS, colX0) Then
                For i = 1 To n
                    X1(i, colX1) = X0(i, colX0)
                Next
                colX1 = colX1 + 1
            End If
        Next
        olsResult1 = OLSEst3aryS(y, X1)
        ssResidual1 = .SumSq(olsResult1(3))
    End If
        
    '2̎cƂɁCFlPl쐬
    fNume = (ssResidual1 - ssResidual0) / J
    fDenom = ssResidual0 / (n - k)
    fValue = fNume / fDenom
    pValue = .F_Dist_RT(fValue, J, n - k)
    
    '쐬āCԂ
    strFvalue = "Fl=" & .Round(fValue, 4) & "C"
    strDf = "Rx(" & J & "," & n - k & ")Fz"
    strPvalue = "Pl=" & .Round(pValue, 4)
    
    OLSdropVarsFtest = strFvalue & strDf & strPvalue
End With
End Function

'OLSDbhat,yhat,ehat3ԂD
Private Function OLSEst3aryS(y, X0)
With WorksheetFunction
    Dim n, k, bhat, X, yhat, ehat
    Dim i, jCol
    'n,k,bhat́COLSƓ
    bhat = OLSE(y, X0)
    n = UBound(X0, 1)
    k = UBound(X0, 2) + 1
    '萔tX쐬
    ReDim X(n, k)
    For i = 1 To n
        X(i, 1) = 1
        For jCol = 2 To k
            X(i, jCol) = X0(i, jCol - 1)
        Next
    Next
    'OLSyhatehat쐬
    yhat = .MMult(X, bhat)
    ReDim ehat(n, 1)
    For i = 1 To n
        ehat(i, 1) = y(i, 1) - yhat(i, 1)
    Next
    
    OLSEst3aryS = Array(bhat, yhat, ehat)
End With
End Function
