ExcelVBAで「かるた」を作ってみた

経緯

子供とかるた遊びをした

ちょうど仕事のVBA改修作業に嫌気がさしていたところ、子供とかるた遊びをして思いついた。

約四半世紀ぶりにかるたをした

そうだ、Excelでかるたを作ろう！

— 青と緑のVBAer (@mechkawa) December 5, 2021

それなりにできたが...

Speakメソッドで音声読み上げ中は操作不能...

と思いきや #助けてVBA メソッドでツイッタランドのつよつよさんから早速ご助言！
解決！！！

Excel VBA の
Sheet1.Range("A1").Speak
のことだとしたら、
Application.Speech.Speak Sheet1.Range("A1").Text, SpeakAsync:=True
にするのは如何でしょう。

— 弁士 (@Benshi_Orator) December 7, 2021

作り方

シート設定

メインシート

シート名を付けておくだけで特にセルに書き込むことは何もない

設定シート

実行ボタンにはかるたを登録

• 上のテーブル名：出題分
• 下のテーブル名：お題リスト

関数はこれだけ

お題	LEFT
	=LEFT([@お題])

お題	LEFT	済
	=LEFT([@お題])

お題リスト（例）

5･7･5っぽいちょうど良さげなネタを拝借。ここは好き好きで。

コード

以下を各モジュールにコピペすればいけるはずです。

標準モジュール

bas1

Option Explicit

Const 縦横比_縦 = 5
Enum cDB
  お題 = 1
  Left = 2
  済 = 3
End Enum

Dim cls_config As Class1
Dim cls_出題 As Class1
Dim cls_main As Class1

Sub 読み上げ()
  With Application.Speech
    .Speak Text:=cls_出題.Areaお題.Text, _
    speakasync:=True
  End With
End Sub

Sub かるた()
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Set cls_config = New Class1
  Set cls_main = New Class1
  Set cls_出題 = New Class1
  
  Call Setup
  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

Private Sub Setup()
  Call Set下ごしらえ
  Call 初期化
  Call Set実行ボタン
  
  Call Set設定シートからメインシートへ転記
  Call Set出題セレクト
End Sub

Function お題に済処理(対象頭文字) As Boolean
  Call 一致したものをお題DBから探す(対象頭文字)
  お題に済処理 = False
  Call フィルタ
  
  Call Set出題セレクト
  お題に済処理 = True
End Function
Function 判定(対象頭文字) As Boolean
  If 対象頭文字 = cls_出題.Area頭文字.Value Then
    判定 = True
  Else
    判定 = False
    MsgBox "ハズレ！"
  End If
End Function
Private Function 一致したものをお題DBから探す(対象頭文字)
  With cls_config
    Dim i As Long
    For i = 1 To .Area頭文字.Rows.Count
      If .Area頭文字.Value2(i, 1) = 対象頭文字 Then
        .Area(i, cDB.済).Value = "o"
        Exit Function
      End If
    Next
  End With
End Function

Private Sub Set出題セレクト()
  On Error GoTo Err
  Dim Arr
  Arr = Shuffle2(cls_config.Areaお題.SpecialCells(xlCellTypeVisible).Value2)
  Dim i, buf
  
  If IsArray(Arr) = False Then
    buf = Arr
  Else
    buf = Arr(1, 1)
  End If
  
  With cls_出題
    .Areaお題.Value = buf
  End With
  Exit Sub
Err:
  Select Case Err.Number
    Case Is = 1004
      Call ゲーム終了
    Case Else
  End Select
End Sub

Private Sub ゲーム終了()
  MsgBox "ゲーム終了！"
  Set cls_config = Nothing
  Set cls_main = Nothing
  Set cls_出題 = Nothing
End Sub

Private Sub 初期化()
  On Error Resume Next
  Application.EnableEvents = False
  With cls_config
    .ws.ShowAllData
    .Area済.Value = ""
  End With
  
  With cls_main
    With .ws
      .Activate
      .Cells(1, 1).Activate
      .Cells.ClearFormats
      .Cells.Interior.Color = vbWhite
    End With
    
    With .Area
      .Font.Size = 50
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
    End With
    
    .ws.Cells.EntireColumn.AutoFit
    Call my表示切替(False)

  End With
  Call フィルタ
  Application.EnableEvents = True

  MsgBox "ゲーム開始！"
End Sub

Private Sub Set設定シートからメインシートへ転記()
  Dim Arr: Arr = Shuffle2(cls_config.Area頭文字.Value2)
  
  With cls_main
    Dim i
    For i = 1 To UBound(Arr)
      .Area(i).Value = Arr(i, 1)
    Next
    
  End With

End Sub

' 配列をシャッフルする関数
Private Function Shuffle2(list2)
  If IsArray(list2) = False Then
    Shuffle2 = list2
  Else
  Dim i, rn, tmp
    For i = 1 To UBound(list2)
        Randomize
        rn = Int(UBound(list2, 1) * Rnd) + 1
        tmp = list2(i, 1)
        list2(i, 1) = list2(rn, 1)
        list2(rn, 1) = tmp
    Next
    Shuffle2 = list2
  End If
End Function
Private Function Shuffle(list)
  Dim i, rn, tmp
    For i = 0 To UBound(list)
        Randomize
        rn = Int(UBound(list) * Rnd)
        tmp = list(i)
        list(i) = list(rn)
        list(rn) = tmp
    Next
    Shuffle = list
End Function

Sub Set下ごしらえ()
  With cls_config
    .wsName = "設定"
    Set .ws = Sheets(.wsName)
    Set .Area = .ws.ListObjects("お題リスト").DataBodyRange
    Set .Areaお題 = .Area.Columns(cDB.お題)
    Set .Area頭文字 = .Area.Columns(cDB.Left)
    Set .Area済 = .Area.Columns(cDB.済)
    
    .cntデータ数 = .Area.Rows.Count
    .cntH = WorksheetFunction.RoundUp(.cntデータ数 / 縦横比_縦, 0)
    .cntW = WorksheetFunction.RoundUp(.cntデータ数 / .cntH, 0)
  
  End With
  
  
  With cls_main
    .wsName = "メイン"
    Set .ws = Sheets(.wsName)
    .ws.Cells.Clear
    
    .cntH = cls_config.cntH
    .cntW = cls_config.cntW
    Set .Area = .ws.Cells(3, 2).Resize(.cntH, .cntW)
  End With
  
  With cls_出題
    .wsName = "設定"
    Set .ws = Sheets(.wsName)
    Set .Area = .ws.ListObjects("出題分").DataBodyRange
    Set .Areaお題 = .Area.Columns(cDB.お題)
    Set .Area頭文字 = .Area.Columns(cDB.Left)
  End With
  
End Sub

Private Sub my表示切替(表示するか否か As Boolean)
  Application.DisplayFormulaBar = 表示するか否か
  ActiveWindow.DisplayHeadings = 表示するか否か
  ActiveWindow.DisplayGridlines = 表示するか否か
End Sub

Private Sub フィルタ()
  cls_config.ws. _
      ListObjects("お題リスト").Range.AutoFilter _
      Field:=cDB.済, Criteria1:="="

End Sub

Private Sub Set実行ボタン()
  Const my表示文字 = "読み上げ"
  Dim Cell対象 As Range
  Set Cell対象 = cls_main.ws.Cells(1, 2)
  With Cell対象
    .FormulaR1C1 = my表示文字
    .Hyperlinks.Add _
        Anchor:=Cell対象, _
        Address:="", _
        SubAddress:="メイン!A1", _
        TextToDisplay:=my表示文字
    .Resize(1, 4).Merge
    .HorizontalAlignment = xlCenter
    .Font.Size = 30
  End With
  

End Sub

シートモジュール

タッチ判定と読み上げのためのイベント用

メイン

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.ScreenUpdating = False
  If Target.Row = 1 Then Exit Sub
  
  With Target
    If IsArray(Target) = True Then
      MsgBox "複数範囲を選択しないでください"
      Exit Sub
    End If
    If bas1.判定(.Value) = True Then
      If bas1.お題に済処理(.Value) = True Then
        .Interior.Color = vbGrayText
        .Font.Color = vbWhite
      End If
    Else
      
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
  Dim wbName: wbName = ThisWorkbook.Name
  Dim procName: procName = Target.Name
  Application.Run wbName & "!" & procName
'  Application.Run "かるた.xlsm!読み上げ"
End Sub

クラスモジュール

セル範囲とかの構造化用。

Class1

Option Explicit

Public Area As Range
Public Areaお題 As Range
Public Area頭文字 As Range
Public Area済 As Range
Public ws As Worksheet
Public wsName As String
Public cntデータ数 As Long
Public cntW As Long
Public cntH As Long

振り返り

Speakメソッドを知れた

通常業務で使うことはまずなさそうな機能だけど、遊ぶ分にはおもちゃが増えたなーといった感じ。

スクレイピング結果を自動読み上げしてながら聞きとかやってる人とかいそう。超聞き取りづらいけど。

Application.Runに可能性を感じた

ハイパーリンクをマクロ実行ボタンと化す術が少し前に話題になっていたので取り入れてみたのですが、

メイン

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
  Dim wbName: wbName = ThisWorkbook.Name
  Dim procName: procName = Target.Name
  Application.Run wbName & "!" & procName
'  Application.Run "かるた.xlsm!読み上げ"
End Sub

ここがCall procNameだと動かないのですが、wbName & "!" & procNameとすればセルの文字を使ってフレキシブルに実行ボタンを作ることができることが分かり、視界が広がりました。

クラスの初期化にもう少し慣れたい

下ごしらえというプロシージャで初期化をすることが多いのですが、初期化部分をクラスモジュール側で完結させた方がいいんだろうなと思いながらも、今回は

Dim cls_config As Class1
Dim cls_出題 As Class1
Dim cls_main As Class1

と3通り初期化内容が異なっていたのでサボってしまった。

これならTypeでいいじゃないかとも思ったけど、ウォッチウィンドウでカタマリで見られるだけでも書きやすさがぐーんと上がるので、使う頻度を上げる意味もあってそのためだけでもクラスを使うようにしています。ハードル下げ大事。

マルチプレイできないかな→Officeスクリプトなるものを知った

というかそもそもマルチプレイってできるのかな

Teamsとかで共同編集モードで操作主の名前を拾うとかできるのかな

と思って調べたらTeams上ではマクロは動きませんと...

代わりにOfficeスクリプトを勧められた...Officeスクリプトなにそれおいしいのからだわhttps://t.co/EPZL09Vx6j

— 青と緑のVBAer (@mechkawa) December 5, 2021

結局、自宅ではライセンスの種類？職場では社内のセキュリティ？が原因なのか、現状Officeスクリプトが使えない状態ということでマルチプレイは今回は断念しましたが、流行具合や興味度合でまた調べてみようと思います。

役に立たない系マクロにようやく手を出せるようになったことが嬉しい

正直、業務では汎用的なちょっとした動作を自動化するアドインを作ってExcelを育てているうちはまだ楽しいのですが、
転記系やフォルダ操作系が面倒で若干飽きてきている節がありました。

web上では「もうそれExcelじゃないじゃん」みたいな神々の遊びを見かけることが少なくありません。
レベル的に手の届かない内容が多く、長らく遊び系に手を出せていませんでした。

そんな中、ひょんなことから役に立たない系に手を出してみたところ、久々に楽しかったのはもとより、回りまわって役に立つネタが回収できるという、充実した趣味の時間を過ごすことができました。

次は何をやろうかしら。