上級93回のコード

#If Win64 Then
   Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
   Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
'↑noteからコピペすると上手く貼りつかないかもです。
Public wsGame As Worksheet
Public wsData As Worksheet
Public nextChar As String
Public count As Long
Public cntFG As Boolean
Public gameFG As Boolean

スタート

Sub start()
   gameFG = True
   Call init
   DoEvents
   
   wsGame.Range("d10") = "しりとりで勝負だ！"
   Sleep 2000
   DoEvents
   
   wsGame.Range("d10") = "まず俺が選ぶぞ･･･"
   Sleep 2000
   DoEvents
   Call tekiTurn("あ")
End Sub

イニット

Sub init()
   Dim num As Integer
   Dim cards() As Integer
   
   Dim i As Integer
   Dim j As Integer
   Dim c As Integer
   Dim r As Integer
   Dim x As Integer
   
   Dim sh As Shape
   
   
   Set wsGame = ThisWorkbook.Worksheets("game")
   Set wsData = ThisWorkbook.Worksheets("data")
   
   
   '時間の初期化（ミリ秒）
   count = 60000
   wsGame.Range("b10") = Int(count / 1000)
   
   num = wsData.Range("B1").End(xlDown).Row
   
   '配置済みのイラストの削除
   For Each sh In wsGame.Shapes
       
       '必要なパーツを除外
       If sh.Name <> "usagi" And sh.Name <> "fukidashi" And sh.Name <> "stBtn" Then
           sh.Delete
       End If
   Next
   
   ReDim cards(1 To num)
   
   For i = 1 To num
   
       cards(i) = i
   
   Next i
   
   Randomize
   
   c = 0
   
   
   'イラストをランダムに配置する処理
   For j = 0 To 3
   
       For i = 0 To 5
       
           r = Int((num - c) * Rnd + 1)
           
           
           
           wsData.Select
           wsData.Shapes("image" & cards(r)).Select
           Selection.Copy
           wsGame.Select
           wsGame.Range("C5").Offset(j, i).Select
           ActiveSheet.Paste
           
           'イラストに引数付きでマクロを登録
           wsGame.Shapes("image" & cards(r)).OnAction = "'imageClick " & cards(r) & "'"
           
           For x = r To num - 1
               cards(x) = cards(x + 1)
           Next x
           
           c = c + 1
           
       Next i
       
   Next j
   
   
   
   wsGame.Range("a1").Select
   
End Sub

カウントダウン

Sub countDown()
   '自ターンかつゲーム進行時のみ減少
   Do While cntFG And gameFG
       count = count - 250
       
       If count < 0 Then
           count = 0
           gameFG = False
           wsGame.Range("d10") = "時間切れだ！お前のまけーーーー！"
       End If
       
       wsGame.Range("b10") = Int(count / 1000)
       DoEvents
       Sleep 250
   Loop
End Sub

敵ターン

Sub tekiTurn(s As String)
   Dim ID As Integer
   Dim num As Integer
   Dim fg As Boolean
   fg = True
   For Each sh In wsGame.Shapes
       If sh.Name <> "usagi" And sh.Name <> "fukidashi" And sh.Name <> "stBtn" Then
           ID = Mid(sh.Name, 6)
           num = hanteiTeki(ID, s)
           
           If num <> 0 Then
               Call imageDelete(ID, num, 1)
               nextChar = getShiri(ID, num)
               wsGame.Range("d10") = "お前の番。「" & nextChar & "」から始まるものだ。"
               fg = False
               
               'カウントダウン解放
               cntFG = True
               Call countDown
               
               Exit For
           End If
       End If
   Next
   
   If fg Then
       wsGame.Range("d10") = "うん！？無いぞ・・・" & vbNewLine & "俺の負けだ"
       gameFG = False
   End If
End Sub

イメージデリート

'正しいイラストをクリックしたときの処理
Sub imageDelete(ID As Integer, num As Integer, mode As Integer)
   Dim msg As String
   
   DoEvents
   
   With wsGame.Shapes("image" & ID).Line
       .Visible = msoTrue
       .ForeColor.RGB = RGB(255, 0, 0)
       .Weight = 6
       .Transparency = 0
   End With
   
   DoEvents
   Select Case mode
       Case 0: '自分のターン
           If num >= 5 Then
               '変な答えを選んだ場合
               msg = "「" & wsData.Cells(ID, num) & "」だって！？？？？"
           Else
               
               msg = "「" & wsData.Cells(ID, num) & "」か・・・"
           End If
       Case 1: '敵のターン
           msg = "「" & wsData.Cells(ID, num) & "」だ。"
   End Select
   
   wsGame.Range("D10") = msg
   
   Sleep 2000
   wsGame.Shapes("image" & ID).Delete
End Sub

イメージクリック

Sub imageClick(ID As Integer)
   Dim num As Integer
   
   'ゲーム進行時かつ自ターンの場合のみ処理
   If gameFG And cntFG Then
       '正しいカードなら列番号numが取得される
       num = hantei(ID)
   
       If num <> 0 Then 'OK
           cntFG = False
           Call imageDelete(ID, num, 0)
           wsGame.Range("D10") = "次は俺の番だな･･･"
           Sleep 1000
           Call tekiTurn(getShiri(ID, num))
       Else 'NG
           count = count - 5000
           wsGame.Range("D3").Interior.Color = RGB(255, 0, 0)
           Sleep 500
           DoEvents
           
           wsGame.Range("D3").Interior.Color = RGB(255, 255, 255)
       End If
   End If
End Sub

ゲットしり

'最後の文字の取得
Function getShiri(ID As Integer, num As Integer) As String
   Dim s As String
   s = Right(wsData.Cells(ID, num), 1)
   
   'ーの時はひとつ前の字を使う
   If s = "ー" Then
       s = Left(Right(wsData.Cells(ID, num), 2), 1)
   End If
   
   getShiri = s
End Function

判定

Function hantei(ID As Integer) As Integer
   num = 0
   
   For i = 2 To 7
       If nextChar = Left(wsData.Cells(ID, i), 1) Then
           num = i
           Exit For
       End If
   Next i
   
   hantei = num
End Function

判定敵

Function hanteiTeki(ID As Integer, s As String) As Integer
   num = 0
   
   For i = 2 To 5 '敵は6列目以降の答えは使えない
       If s = Left(wsData.Cells(ID, i), 1) Then
           num = i
           Exit For
       End If
   Next i
   
   hanteiTeki = num
End Function