anonymous 相性占い
No License VBA
2020年12月28日
Copy Clone
Option Explicit

Sub Uranai()

    ' 相性を占いたい男女の名前をそれぞれ半角カタカナで設定してください。
    Dim S_Name      As String, S_Int       As String, S_Wk       As String
    Dim i           As Long
    Dim Man         As String: Man = "ニシジマヒデトシ"
    Dim Woman       As String: Woman = "アラガキユイ"
    
    ' 名前に濁音、ぱく音があれば消去し、並べて表示
    S_Name = Replace(Replace(Man & Woman, "゙", ""), "゚", ""): Debug.Print S_Name ' 名前を並べて表示
    
    ' 名前の数値化
    For i = 1 To Len(S_Name)
        If InStr("アカサタナハマヤラワァャ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "1"    ' 母音アは 1
        If InStr("イキシチニヒミリィ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "2"       '     イは 2
        If InStr("ウクスツヌフムユルゥュッ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "3"    '     ウは 3
        If InStr("エケセテネヘメレェ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "4"       '     エは 4
        If InStr("オコソトノホモヨロヲォョ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "5"    '     オは 5
        If InStr("ン", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "0"               '     ンは 0
    Next
    
    ' 100%以下になるまで計算を繰り返す
    Do
        Debug.Print S_Int   ' 数値の表示
        If S_Int = "100" Or Len(S_Int) < 3 Then Exit Do
        
        ' 隣り合う数値を足し、1桁目だけを再度並べていく
        S_Wk = ""
        For i = 1 To Len(S_Int) - 1
            S_Wk = S_Wk & Right(CStr(Val(Mid(S_Int, i, 1)) + Val(Mid(S_Int, i + 1, 1))), 1)
        Next
        S_Int = S_Wk
    Loop
    
    Debug.Print "二人の相性は " & S_Int; " %です"

End Sub
Option Explicit

Sub Uranai()

    ' 相性を占いたい男女の名前をそれぞれ半角カタカナで設定してください。
    Dim S_Name      As String, S_Int       As String, S_Wk       As String
    Dim i           As Long
    Dim Man         As String: Man = "ニシジマヒデトシ"
    Dim Woman       As String: Woman = "アラガキユイ"
    
    ' 名前に濁音、ぱく音があれば消去し、並べて表示
    S_Name = Replace(Replace(Man & Woman, "゙", ""), "゚", ""): Debug.Print S_Name ' 名前を並べて表示
    
    ' 名前の数値化
    For i = 1 To Len(S_Name)
        If InStr("アカサタナハマヤラワァャ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "1"    ' 母音アは 1
        If InStr("イキシチニヒミリィ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "2"       '     イは 2
        If InStr("ウクスツヌフムユルゥュッ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "3"    '     ウは 3
        If InStr("エケセテネヘメレェ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "4"       '     エは 4
        If InStr("オコソトノホモヨロヲォョ", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "5"    '     オは 5
        If InStr("ン", Mid(S_Name, i, 1)) > 0 Then S_Int = S_Int & "0"               '     ンは 0
    Next
    
    ' 100%以下になるまで計算を繰り返す
    Do
        Debug.Print S_Int   ' 数値の表示
        If S_Int = "100" Or Len(S_Int) < 3 Then Exit Do
        
        ' 隣り合う数値を足し、1桁目だけを再度並べていく
        S_Wk = ""
        For i = 1 To Len(S_Int) - 1
            S_Wk = S_Wk & Right(CStr(Val(Mid(S_Int, i, 1)) + Val(Mid(S_Int, i + 1, 1))), 1)
        Next
        S_Int = S_Wk
    Loop
    
    Debug.Print "二人の相性は " & S_Int; " %です"

End Sub
昔流行った男女の名前を数値化して相性を占うVBAです。
結果はイミディエイトウインドウに表示します。

占いの詳細はリンクを見てください。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1211464232
No one still commented. Please first comment.