Excelによる、ベイジアンネットワークのもとでの確率推論。

COPY ALL

Option Explicit

' https://hitorimarketing.net/tools/bayesian-network-gui.html
' by hawcas, b20180901

Dim CheckBoxID As Integer
Dim CheckBoxBIN As Integer
Dim Numerator As String
Dim Denominator As String

' 〓"NETWORK"表の構造
Const TOTALNODE As Integer = 13 ' ノードの数を指定
Const TRUEFALSELIST As String = "U2:V14" ' チェックボックスの管理表を範囲で指定
Const FORMULASTRINGSLIST As String = "U17" ' 式を作るための表を左上角のセルで指定
' 〓"TABLE"表の構造
Const TABLENAME As String = "テーブル1" ' テーブル名
Const HEADWORDOFSUBTOTAL As String = "Π" ' 総積を計算している列の名前

Private Function GetCheckBoxOwner(ByVal checkbox_id As Integer) As String
' 〓ノード名
GetCheckBoxOwner = Application.WorksheetFunction.Choose(checkbox_id, _
    "Alice", "Annie", "Johanna", "Nickie", _
    "Hana", "Beth", "Sally", _
    "Liz", "Tricia", _
    "Sarah", "Clarice", "Enid", _
    "LEADER")

End Function

Private Function GetMarginsAddress(ByVal checkbox_id As Integer) As String
' 〓確率の表示位置(ノード名と対応)
GetMarginsAddress = Application.WorksheetFunction.Choose(checkbox_id, _
    "M3", "J1", "G3", "E6", _
    "D14", "E19", "H22", _
    "O21", "Q13", _
    "J8", "H16", "N16", _
    "K13")

End Function

Private Function GetCheckBoxValue(ByVal checkbox_bin As Integer) As String
' 〓2値の内容
GetCheckBoxValue = Application.WorksheetFunction.Choose(checkbox_bin, _
    "YES", "NO")

End Function

Private Function GetTextStrings(ByVal checkbox_id As String, _
    ByVal checkbox_bin As String) As String
' 計算式を作成(自ノード含む：分子部分)
Dim listofFormulaStrings As Range
Set listofFormulaStrings = Range(FORMULASTRINGSLIST)
Dim arraySize As Integer
    arraySize = Application.WorksheetFunction.CountIf(Range(TRUEFALSELIST), _
        True)
Dim textArray()
ReDim textArray(arraySize)
Dim arrayCounter As Integer
    arrayCounter = 1
Dim x As Integer, y As Integer
For x = 0 To 1 ' range(u17:v29)の空白でないセルの内容を配列にそのまま格納
    For y = 0 To TOTALNODE - 1
        If listofFormulaStrings.Offset(y, x).Value <> "" Then
            textArray(arrayCounter) = listofFormulaStrings.Offset(y, x).Value
            arrayCounter = arrayCounter + 1
        End If
    Next y
Next x
Dim temporaryOne As String
    temporaryOne = TABLENAME & "[" & checkbox_id & "],""" & checkbox_bin & """"
Dim myExistence As Boolean
    myExistence = CheckMyExistenceInArray(textArray, arraySize, temporaryOne)
Dim selectAll As String
    selectAll = ""
If myExistence = True Then ' 自分を含む場合
    For x = 1 To arraySize
        If textArray(x) <> temporaryOne Then
            selectAll = selectAll & "," & textArray(x) ' 自分以外で文字列を作成
        End If
    Next
Else ' 自分を含まない場合
    For x = 1 To arraySize
        selectAll = selectAll & "," & textArray(x) ' すべての配列で文字列を作成
    Next
End If
selectAll = selectAll & "," & temporaryOne ' 末尾に自分を強制的に加える

GetTextStrings = selectAll

End Function

Private Function GetTextStringswithoutMe(ByVal select_all As String, _
    ByVal checkbox_id As String, ByVal checkbox_bin As String) As String
' 計算式を作成(自ノード含まず：分母部分)
Dim selectAllwithoutMe As String
    selectAllwithoutMe = select_all
Dim temporaryOne As String
    temporaryOne = "," & TABLENAME & "[" & checkbox_id & "],""" & checkbox_bin & _
        """"
selectAllwithoutMe = Replace(select_all, temporaryOne, "")

GetTextStringswithoutMe = selectAllwithoutMe

End Function

Private Function CheckMyExistenceInArray(ByVal text_array, _
    ByVal array_size As Integer, ByVal temporary_one As String) As Boolean

Dim i As Integer
For i = 1 To array_size
    If text_array(i) = temporary_one Then
        CheckMyExistenceInArray = True
    End If
Next

End Function

Sub checkBoxAliceYes_Click()
CheckBoxID = 1: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxAliceNo_Click()
CheckBoxID = 1: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxAnnieYes_Click()
CheckBoxID = 2: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxAnnieNo_Click()
CheckBoxID = 2: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxJohannaYes_Click()
CheckBoxID = 3: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxJohannaNo_Click()
CheckBoxID = 3: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxNickieYes_Click()
CheckBoxID = 4: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxNickieNo_Click()
CheckBoxID = 4: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxHanaYes_Click()
CheckBoxID = 5: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxHanaNo_Click()
CheckBoxID = 5: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxBethYes_Click()
CheckBoxID = 6: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxBethNo_Click()
CheckBoxID = 6: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxSallyYes_Click()
CheckBoxID = 7: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxSallyNo_Click()
CheckBoxID = 7: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxLizYes_Click()
CheckBoxID = 8: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxLizNo_Click()
CheckBoxID = 8: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxTriciaYes_Click()
CheckBoxID = 9: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxTriciaNo_Click()
CheckBoxID = 9: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxSarahYes_Click()
CheckBoxID = 10: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxSarahNo_Click()
CheckBoxID = 10: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxClariceYes_Click()
CheckBoxID = 11: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxClariceNo_Click()
CheckBoxID = 11: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxEnidYes_Click()
CheckBoxID = 12: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxEnidNo_Click()
CheckBoxID = 12: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxLEADERYes_Click()
CheckBoxID = 13: CheckBoxBIN = 1
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Sub checkBoxLEADERNo_Click()
CheckBoxID = 13: CheckBoxBIN = 2
Call ControllCheckBox(CheckBoxID, CheckBoxBIN)
End Sub

Private Sub ControllCheckBox(ByVal checkbox_id As Integer, _
    checkbox_bin As Integer)
' [PreviousAction]→"ControllCheckBox"→"SetFromula"→"ConvertTextToFormula"
Dim partnerCheckboxBin As Integer
If checkbox_bin = 1 Then
    partnerCheckboxBin = 2
Else
    partnerCheckboxBin = 1
End If
Dim myownObjectName As String
    myownObjectName = "checkBox" & GetCheckBoxOwner(checkbox_id) & _
        GetCheckBoxValue(checkbox_bin)
Dim partnerObjectName As String
    partnerObjectName = "checkBox" & GetCheckBoxOwner(checkbox_id) & _
        GetCheckBoxValue(partnerCheckboxBin)
If ActiveSheet.CheckBoxes(myownObjectName).Value = xlOn And _
    ActiveSheet.CheckBoxes(partnerObjectName).Value = xlOn Then
    ActiveSheet.CheckBoxes(partnerObjectName).Value = xlOff
End If

Call SetFormula

End Sub

Private Sub SetFormula()

Dim formulaTail, formulaHeadYES, formulaHeadNO, myFormula
Dim targetOne As Range
Dim targetTwo As Range
Set targetTwo = Range(TRUEFALSELIST).Range("A1").Offset(-1, -1)

Dim x As Integer, y As Integer
For y = 1 To TOTALNODE
    Set targetOne = Range(GetMarginsAddress(y))
    For x = 1 To 2
        Select Case x
        Case 1
            formulaHeadYES = "=IF(AND(" & targetTwo.Offset(y, 1).Address & _
                ",NOT(" & targetTwo.Offset(y, 2).Address & _
                ")),1,IF(AND(NOT(" & targetTwo.Offset(y, 1).Address & ")," _
                & targetTwo.Offset(y, 2).Address & "),0,"
            myFormula = formulaHeadYES
        Case 2
            formulaHeadNO = "=IF(AND(NOT(" & targetTwo.Offset(y, 1).Address & _
                ")," & targetTwo.Offset(y, 2).Address & _
                "),1,IF(AND(" & targetTwo.Offset(y, 1).Address & ",NOT(" _
                & targetTwo.Offset(y, 2).Address & ")),0,"
            myFormula = formulaHeadNO
        End Select
        Call ConvertTextToFormula(GetCheckBoxOwner(y), GetCheckBoxValue(x)) ' ex."Alice","YES"
        formulaTail = Numerator & " / " & Denominator
        myFormula = myFormula & formulaTail & "))"
        targetOne.Offset(x - 1, 0).Formula = myFormula
        formulaHeadYES = "": formulaHeadNO = "": formulaTail = "": myFormula = ""
    Next x
Next y
Numerator = "": Denominator = ""

End Sub

Private Sub ConvertTextToFormula(ByVal checkbox_id As String, _
    ByVal checkbox_bin As String)

Dim temporaryNumerator As String
temporaryNumerator = "SUMIFS(" & TABLENAME & "[" & HEADWORDOFSUBTOTAL & "]" & _
    GetTextStrings(checkbox_id, checkbox_bin) & ")"
Dim temporaryDenominator As String
temporaryDenominator = "SUMIFS(" & TABLENAME & "[" & HEADWORDOFSUBTOTAL & "]" & _
    GetTextStringswithoutMe(GetTextStrings(checkbox_id, checkbox_bin), _
    checkbox_id, checkbox_bin) & ")"
If temporaryDenominator = "SUMIFS(" & TABLENAME & "[" & HEADWORDOFSUBTOTAL & "])" Then
    temporaryDenominator = "SUM(" & TABLENAME & "[" & HEADWORDOFSUBTOTAL & "])"
End If

Numerator = temporaryNumerator
Denominator = temporaryDenominator

End Sub