ご存じですか？双子の存在を！（同じステータスを持つこころ一覧）

フローラ、ビアンカ、デボラのこころ、ステータスがまったく同一ですよね。

他にもそのようなこころがあるか調べたくなり、折角なので、こころマクロの「こころ一覧シート」で、指定したこころと類似しているこころのスコアを算出する機能を追加してみました。

操作は簡単、図鑑Noのセルをダブルクリックするだけ

このように類似度スコアが表示されます。差異を数字で算出しており0が満点です

いい感じで動作してくれたので、ぽちぽちクリックしてみて楽しんでいました。これはこれで楽しかったのですが、全こころを総当たりで調べてみたい衝動を抑えきれなくなり、マクロで一覧表を作ってみました。

いやはや、既知の組み合わせもあれば、意外なのもあります。

差分ゼロで完全一致している、一卵性と言ってもよいであろうこころは、
・ビアンカ／フローラ／デボラ
・ぶっちズキーニャ／タコメット／おみくじミミック
・エデンの戦士たち２／ダークキング
・パイレーツプリズナー／じこくのもんばん
・クロコダイン／しろバラのきし
・ナウマンボーグ／あくま神官
・リカント／キラービー
・ドラゴン／グレムリン
・ミケまどう／のろいの岩
となりました。

地方限定のまものと同性能のこころを用意して、地域格差の解消を狙っている点、運営の工夫を感じます。次が印象深かった双子たちです。

一覧作成機能は、メニュー化するほどでもないかなあと、モジュールにそっと存在させていて、以下がそのコードです。

Sub 類似度一括チェック()

    Application.ScreenUpdating = False
    Sheets("こころ一覧").Select
    Dim r, r2, r3, i, LastR, c, Score, SV, CV､TV
    LastR = Range("e4").End(xlDown).Row
    r2 = 0
    SV = Range(Cells(5, 14), Cells(LastR, 21))
    CV = Range(Cells(5, 10), Cells(LastR, 10))
    TV = Sheets("類似").Range("A3:AC300")
    
    Dim StrAll As String
    
    For r = 5 To LastR
        For r3 = 5 To LastR
            If r <> r3 Then
                For c = 1 To 8
                    Score = Score + Abs(SV(r3 - 4, c) - SV(r - 4, c))
                Next c
                If Score <= 10 Then
                    If InStr(StrAll, Cells(r, 5) & Cells(r3, 5)) = 0 And InStr(StrAll, Cells(r3, 5) & Cells(r, 5)) = 0 Then
                        StrAll = StrAll & "," & Cells(r, 5) & Cells(r3, 5)
                        r2 = r2 + 1
                        TV(r2, 1) = Score
                        For i = 1 To 8
                            TV(r2, i + 1) = SV(r3 - 4, i) - SV(r - 4, i)
                            TV(r2, i + 11) = SV(r - 4, i)
                            TV(r2, i + 21) = SV(r3 - 4, i)
                        Next i
                        TV(r2, 10) = Cells(r, 5)
                        TV(r2, 11) = CV(r - 4, 1)
                        TV(r2, 20) = Cells(r3, 5)
                        TV(r2, 21) = CV(r3 - 4, 1)
                    End If
                End If
                Score = 0
            End If
        Next r3
    Next r
    Sheets("類似").Range("A3:AC300") = TV
    Sheets("類似").Select

Sub 類似度一括チェック()

Application.ScreenUpdating = False

Sheets("こころ一覧").Select

Dim r, r2, r3, i, LastR, c, Score, SV, CV､TV

LastR = Range("e4").End(xlDown).Row

r2 = 0

SV = Range(Cells(5, 14), Cells(LastR, 21))

CV = Range(Cells(5, 10), Cells(LastR, 10))

TV = Sheets("類似").Range("A3:AC300")

Dim StrAll As String

For r = 5 To LastR

For r3 = 5 To LastR

If r <> r3 Then

For c = 1 To 8

Score = Score + Abs(SV(r3 - 4, c) - SV(r - 4, c))

Next c

If Score <= 10 Then

If InStr(StrAll, Cells(r, 5) & Cells(r3, 5)) = 0 And InStr(StrAll, Cells(r3, 5) & Cells(r, 5)) = 0 Then

StrAll = StrAll & "," & Cells(r, 5) & Cells(r3, 5)

r2 = r2 + 1

TV(r2, 1) = Score

For i = 1 To 8

TV(r2, i + 1) = SV(r3 - 4, i) - SV(r - 4, i)

TV(r2, i + 11) = SV(r - 4, i)

TV(r2, i + 21) = SV(r3 - 4, i)

Next i

TV(r2, 10) = Cells(r, 5)

TV(r2, 11) = CV(r - 4, 1)

TV(r2, 20) = Cells(r3, 5)

TV(r2, 21) = CV(r3 - 4, 1)

End If

Score = 0

End If

Next r3

Next r

Sheets("類似").Range("A3:AC300") = TV

Sheets("類似").Select

ここで一つ問題が・・・。単純に「こころ１×こころ２」のように総当たりで走査しているので、主体が変わった時に組み合わせがダブってしまうのですね。「こころ１×こころ２」と「こころ２×こころ１」、両方のパターンが検出されてしまうわけです。これ、組み合わせの段階で処理すべきか少し迷いました。でも、大した組み合わせ数ではないので、こころの名前を文字列連結させ、発見した組み合わせパターンとして文字列変数に追記格納、その際に、主客を逆転させた文字列も併せて追記格納し、いずれも格納されていない場合のみ採用するというロジックを入れました。これにより、ビアンカフローラが発見済みの場合、フローラビアンカは却下されるようになり、たったこの2行を追加するのみで解決できて、ロジックで解決する醍醐味とでも言いましょうか、作っていてとても楽しかったです。

 If InStr(StrAll, Cells(r, 5) & Cells(r3, 5)) = 0 And InStr(StrAll, Cells(r3, 5) & Cells(r, 5)) = 0 Then
                        StrAll = StrAll & "," & Cells(r, 5) & Cells(r3, 5)

1 2	If InStr(StrAll, Cells(r, 5) & Cells(r3, 5)) = 0 And InStr(StrAll, Cells(r3, 5) & Cells(r, 5)) = 0 Then StrAll = StrAll & "," & Cells(r, 5) & Cells(r3, 5)