VBAサンプル集
Excel将棋:棋譜ファイルから対局一覧作成(№19)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
公開日:2020-08-31 最終更新日:2020-08-31

Excel将棋:棋譜ファイルから対局一覧作成(№19)


VBA マクロ Excel将棋

Excelで将棋を作るシリーズの当初目標の、人vs人で動かしてゲームとして成立するところまでは完成しました。


今回は機能拡張として、棋譜ファイルを読み込み対局一覧を作成します。
複数の棋譜ファイルも一度に処理できるようにしています。
また、その一覧のファイル名をダブルクリックすることで、棋譜の自動再現も動くようにしました。

今回追加した機能は以下になります。
・対局一覧シートを追加
・棋譜ファイル(複数可)を読み込み対局一覧を作成
・対局一覧のファイル名ダブルクリックで棋譜を自動再生

対局一覧のシート

VBA マクロ Excel将棋

将棋ウォーズのKIFを参考に作成しています。
以下で、KIFファイルをダウンロードできます。
項目は以下です
開始日時 ・・・ ここのダブルクリックで棋譜の自動再生が始まります。
先手
後手
棋戦
持ち時間
先手の戦型
後手の戦型
先手の手筋
後手の手筋
先手の備考
後手の備考
手合割
手数

Excel将棋の動作

VBA マクロ Excel将棋

全体構成図

VBA マクロ Excel将棋

太線部分が今回新規作成した部分になります。

Excel将棋のダウンロード

№19.Excel将棋:棋譜ファイルから対局一覧作成
shogi_19.zip shogi_19.xlsm ・・・ 現在の最終版

他のゲーム(数独やオセロ)も含めたダウンロード一覧は以下になります。

新規追加したVBAコード

標準モジュール

Option Explicit

Sub ゲーム開始()
  Dim obj将棋 As cls将棋進行
  Set obj将棋 = New cls将棋進行
  obj将棋.ゲーム開始
End Sub

Sub 対局一覧作成()
  Dim vFile As Variant
  vFile = Application.GetOpenFilename(FileFilter:="KIFファイル,*.kif", _
                    MultiSelect:=True)
  If Not IsArray(vFile) Then
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim tbl As ListObject
  Set tbl = getTable(ws, "tbl対局一覧")
  
  Dim lastRow As Long
  lastRow = tbl.DataBodyRange.Rows.Count
  Do Until WorksheetFunction.CountA(tbl.DataBodyRange.Rows(lastRow)) > 0
    lastRow = lastRow - 1
  Loop
  
  On Error Resume Next
  
  Dim objKif読込 As clsKIF読込
  Dim playTime As Date
  Dim i As Long, j As Long
  For i = LBound(vFile) To UBound(vFile)
    Set objKif読込 = New clsKIF読込
    Call objKif読込.棋譜読込(vFile(i))
    With tbl.DataBodyRange
      playTime = objKif読込.開始日時
      j = WorksheetFunction.Match(CDbl(playTime), tbl.DataBodyRange.Columns(tbl.ListColumns("開始日時").Index), 0)
      If Err Then
        lastRow = lastRow + 1
        j = lastRow
      End If
      
      .Cells(j, tbl.ListColumns("開始日時").Index) = objKif読込.開始日時
      .Cells(j, tbl.ListColumns("先手").Index) = objKif読込.先手
      .Cells(j, tbl.ListColumns("後手").Index) = objKif読込.後手
      .Cells(j, tbl.ListColumns("棋戦").Index) = objKif読込.棋戦
      .Cells(j, tbl.ListColumns("持ち時間").Index) = objKif読込.持ち時間
      .Cells(j, tbl.ListColumns("先手の戦型").Index) = objKif読込.先手の戦型
      .Cells(j, tbl.ListColumns("後手の戦型").Index) = objKif読込.後手の戦型
      .Cells(j, tbl.ListColumns("先手の手筋").Index) = objKif読込.先手の手筋
      .Cells(j, tbl.ListColumns("後手の手筋").Index) = objKif読込.後手の手筋
      .Cells(j, tbl.ListColumns("先手の備考").Index) = objKif読込.先手の備考
      .Cells(j, tbl.ListColumns("後手の備考").Index) = objKif読込.後手の備考
      .Cells(j, tbl.ListColumns("手合割").Index) = objKif読込.手合割
      .Cells(j, tbl.ListColumns("手数").Index) = objKif読込.手数
      .Cells(j, tbl.ListColumns("KIFファイル").Index) = vFile(i)
      
      If objKif読込.手数 Mod 2 = 0 Then
        .Cells(j, tbl.ListColumns("先手").Index).Font.Bold = False
        .Cells(j, tbl.ListColumns("後手").Index).Font.Bold = True
      Else
        .Cells(j, tbl.ListColumns("先手").Index).Font.Bold = True
        .Cells(j, tbl.ListColumns("後手").Index).Font.Bold = False
      End If
    End With
  Next
  
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub

Function getTable(ByVal ws As Worksheet, _
         ByVal argName As String) As ListObject
  Set getTable = Nothing
  Dim tbl As ListObject
  For Each tbl In ws.ListObjects
    If tbl.Name = argName Then
      Set getTable = tbl
      Exit Function
    End If
  Next
End Function

シートモジュール:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Intersect(Columns(1), Target.Item(1)) Is Nothing Then
    Exit Sub
  End If
  
  Cancel = True
  
  Worksheets("Excel将棋").Select
  Dim obj将棋 As cls将棋進行
  Set obj将棋 = New cls将棋進行
  obj将棋.ゲーム開始
  Call obj将棋.棋譜読込(Target.Item(1).Value)
End Sub

このシート自体のシート名は任意です。
ただし、このVBAで将棋盤を作成するシートは「Excel将棋」の固定名称にしています。

棋譜読込クラス:cls棋譜読込

Option Explicit

'プロパティ作成を省略した公開変数
Public 先手 As String
Public 後手 As String
Public 開始日時 As Date
Public 棋戦 As String
Public 持ち時間 As Long
Public 先手の戦型 As String
Public 後手の戦型 As String
Public 先手の手筋 As String
Public 後手の手筋 As String
Public 先手の備考 As String
Public 後手の備考 As String
Public 手合割 As String
Public 勝敗コメント As String
Public 手数 As Long

'KIF棋譜形式のclsKIFの配列
Private pAryKIF() As clsKIF

'**********************************************************************
' 公開プロパティ
'**********************************************************************

Public Property Get KIF配列() As clsKIF()
  KIF配列 = pAryKIF
End Property

'**********************************************************************
' イベント
'**********************************************************************

Private Sub Class_Initialize()
  手数 = 0
End Sub

'**********************************************************************
' 公開メソッド
'**********************************************************************

'拡張子".kif"のShift-JISとUTF-8に対応
Public Function 棋譜読込(ByVal argFile As String, _
             Optional ByVal CharSet As String = "SHIFT-JIS") _
             As Boolean
  'KIFファイルを読み込んで配列に
  If KIF棋譜読込(readKif(argFile)) Then
    棋譜読込 = True
  Else
    棋譜読込 = False
  End If
End Function

'KIF形式ファイルからの棋譜の配列を読み盤面を再現する
Private Function KIF棋譜読込(ByRef argAry() As String) As Boolean
  Dim sSplit() As String
  Dim i As Long, j As Long
  
  j = 1
  For i = LBound(argAry) To UBound(argAry)
    Select Case True
      Case Trim(argAry(i)) = ""
        '空行
      Case Left(argAry(i), 1) = "#", Left(argAry(i), 1) = "*"
        'コメント
      Case InStr(argAry(i), ":") >= 1
        Call midString(先手, argAry(i), "先手")
        Call midString(後手, argAry(i), "後手")
        Call midString(開始日時, argAry(i), "開始日時")
        Call midString(棋戦, argAry(i), "棋戦")
        Call midString(持ち時間, argAry(i), "持ち時間")
        Call midString(先手の戦型, argAry(i), "先手の戦型")
        Call midString(後手の戦型, argAry(i), "後手の戦型")
        Call midString(先手の手筋, argAry(i), "先手の手筋")
        Call midString(後手の手筋, argAry(i), "後手の手筋")
        Call midString(先手の備考, argAry(i), "先手の備考")
        Call midString(後手の備考, argAry(i), "後手の備考")
        Call midString(手合割, argAry(i), "手合割")
      Case IsNumeric(Split(Trim(argAry(i)), " ")(0))
        sSplit = Split(Trim(argAry(i)), " ")
        If IsNumeric(sSplit(0)) Then
          ReDim Preserve pAryKIF(1 To j)
          Set pAryKIF(j) = parseKif(argAry(i))
          If pAryKIF(j).手数 < 0 Then
            KIF棋譜読込 = False
            Exit Function
          End If
          If pAryKIF(j).筋 > 0 Then
            If 手数 < pAryKIF(j).手数 Then
              手数 = pAryKIF(j).手数
            End If
          End If
          j = j + 1
        End If
      Case Else
        勝敗コメント = Trim(argAry(i))
    End Select
  Next
  
  KIF棋譜読込 = True
End Function

Private Sub midString(ByRef rtnStr As Variant, _
           ByVal argStr As String, _
           ByVal keyStr As String)
  If Left(Trim(argStr), Len(keyStr) + 1) = keyStr & ":" Then
    Select Case TypeName(rtnStr)
      Case "Date"
        rtnStr = CDate(Trim(Mid(argStr, Len(keyStr) + 2)))
      Case "Long", "Integer", "Double", "Single"
        rtnStr = Val(Trim(Mid(argStr, Len(keyStr) + 2)))
      Case Else
        rtnStr = Trim(Mid(argStr, Len(keyStr) + 2))
    End Select
  End If
End Sub

Private Function parseKif(ByVal argKif As String) As clsKIF
'  On Error GoTo ErrExit
  Set parseKif = New clsKIF
  
  Const cns漢数字 = "一二三四五六七八九"
  Dim sSplit() As String
  argKif = Replace(argKif, "(", " ")
  argKif = Replace(argKif, ")", " ")
  argKif = Replace(argKif, "/", " ")
  argKif = WorksheetFunction.Trim(argKif)
  sSplit = Split(argKif, " ")
  
  parseKif.手数 = sSplit(0)
  If Not IsNumeric(sSplit(0)) Or _
    Left(sSplit(1), 1) < "1" Or Left(sSplit(1), 1) > "9" Then
    parseKif.駒 = sSplit(1)
    Exit Function
  End If
  
  parseKif.筋 = StrConv(Left(sSplit(1), 1), vbNarrow)
  parseKif.段 = InStr(cns漢数字, Mid(sSplit(1), 2, 1))
  If Mid(sSplit(1), 3, 1) = "成" Then
    parseKif.駒 = Mid(sSplit(1), 4, 1)
  Else
    parseKif.駒 = Mid(sSplit(1), 3, 1)
  End If
  If Right(sSplit(1), 1) = "成" Then
    parseKif.成 = "成"
  End If
  
  Select Case UBound(sSplit)
    Case 3
      parseKif.時間1手 = mmss2hhmmss(sSplit(2))
      parseKif.時間累計 = CDate(sSplit(3))
    Case Is >= 4
      parseKif.元筋 = Left(sSplit(2), 1)
      parseKif.元段 = Right(sSplit(2), 1)
      parseKif.時間1手 = mmss2hhmmss(sSplit(3))
      parseKif.時間累計 = CDate(sSplit(4))
    Case Else
      parseKif.手数 = -1
      Exit Function
  End Select
  Exit Function
  
ErrExit:
  parseKif.手数 = -1
End Function

Private Function readKif(ByVal argFile As String, _
             Optional ByVal CharSet As String = "SHIFT-JIS") _
             As String()
  Dim strRec As String
  Dim aryRec() As String
  
  'SHIFT-JISで読んで"先手:"が無ければUTF-8で読み直す
  strRec = readStream(argFile, CharSet)
  If UCase(CharSet) = "SHIFT-JIS" And InStr(strRec, "先手:") = 0 Then
    strRec = readStream(argFile, "UTF-8")
  End If
  
  readKif = Split(Replace(strRec, vbCrLf, vbLf), vbLf)
End Function

Private Function readStream(ByVal argFile As String, _
              ByVal CharSet As String) As String
  With CreateObject("ADODB.Stream")
    .CharSet = CharSet
    .Open
    .LoadFromFile argFile
    readStream = .ReadText
    .Close
  End With
End Function

Private Function mmss2hhmmss(ByVal mmss As String) As Date
  If Len(mmss) = Len(Replace(mmss, ":", "")) + 1 Then
    mmss = "0:" & mmss
  End If
  If IsDate(mmss) Then
    mmss2hhmmss = CDate(mmss)
  Else
    mmss2hhmmss = 0
  End If
End Function

棋譜フォーム「frm棋譜」の中で処理していたKIFファイルの処理をこちらに移動しています。
「frm棋譜」からもこのクラスを通してKIFファイルを処理するように変更しています。

KIFクラス:clsKIF

Option Explicit

Public 手数 As Integer
Public 筋 As Integer
Public 段 As Integer
Public 駒 As String
Public 成 As String
Public 元筋 As Integer
Public 元段 As Integer
Public 時間1手 As Date
Public 時間累計 As Date

Excel将棋の目次

№1. Excel将棋:マクロVBAの学習用
・Excel将棋の要件定義 ・Excel将棋のシート作成 ・Excel将棋の目次
№2. Excel将棋:クラスの設計
・作成するクラスの役割と作成順 ・作成するクラスのメンバー一覧 ・駒の移動の定義 ・Excel将棋の目次
№3. Excel将棋:駒クラスの作成
・位置クラス ・移動クラス ・駒クラス ・駒クラスVBAの解説 ・使用しているVBAの参考ページ ・Excel将棋の目次
№4. Excel将棋:駒クラスの単体テスト
・駒クラスのテスト内容 ・駒クラスのテストVBAコード ・駒クラスのテストVBAの結果 ・Excel将棋の目次
№5. Excel将棋:駒台クラスの作成&単体テスト
・駒クラス ・駒台クラスVBAの解説 ・駒台クラスのテストVBAコード ・駒クラスのテストVBAの結果 ・Excel将棋の目次
№6. Excel将棋:位置クラスをデフォルトインスタンスに変更
・デフォルトインスタンスに変更する理由と方法 ・位置クラスのインポート用ソース ・cls位置とg位置の使い方の違い ・位置クラス変更に伴う駒クラスの変更 ・Excel将棋の目次
№7. Excel将棋:将棋盤クラスの作成&単体テスト
・将棋盤クラス ・将棋盤クラスVBAの解説 ・将棋盤クラスのテストVBAコード ・将棋盤クラスのテストVBAの結果 ・Excel将棋の目次
№8. Excel将棋:将棋進行クラスの作成
・将棋進行クラス ・将棋進行クラスVBAの解説 ・将棋進行クラスの起動方法 ・将棋盤クラスのテストVBAの結果 ・Excel将棋の目次
№9. Excel将棋:駒を動かす
・駒クラスにプロパティ追加 ・将棋進行クラスの変更点 ・将棋進行クラスのVBA ・Excel将棋の実行動作 ・Excel将棋の目次
№10. Excel将棋:相手の駒を取る、持ち駒を打つ
・主な変更追加箇所 ・全体の構成 ・Excel将棋の動作 ・Excel将棋の全VBAコード ・Excel将棋の目次
№11. Excel将棋:駒を成る
・主な変更追加箇所 ・Excel将棋の動作 ・変更したクラスのVBA ・Excel将棋の目次
№12. Excel将棋:棋譜をユーザーフォームに表示する
・棋譜について ・主な変更内容 ・ユーザーフォームの作成 ・Excel将棋の動作 ・変更したクラスのVBA ・Excel将棋の目次
№13. Excel将棋:棋譜選択でその時点の盤面に戻す
・Excel将棋の動作 ・全体構成図 ・全プロシージャー・プロパティの一覧 ・クリックで着手した時の主なプロシージャーの流れ ・Excel将棋のダウンロード ・Excel将棋の目次
№14. Excel将棋:棋譜ファイルの出力と読込自動再生
・Excel将棋の動作 ・VBAの修正箇所について ・Excel将棋のダウンロード ・棋譜KIFファイルのサンプル ・Excel将棋の目次
№15. Excel将棋:反則(禁じ手)判定
・反則(禁じ手) ・Excel将棋の動作 ・各クラスの共通で持つプロパティを整理 ・VBAの修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№16. Excel将棋:終局(詰み)判定と打ち歩詰め
・反則(禁じ手) ・Excel将棋の動作 ・VBAの追加・修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№17. Excel将棋:千日手と連続王手の千日手
・反則(禁じ手) ・Excel将棋の動作 ・VBAの修正箇所について ・Excel将棋のダウンロード ・Excel将棋の目次
№18 Excel将棋:ひとまず完成、これまでとこれから
・Excel将棋のこれから ・Excel将棋の目次 ・Excel将棋のダウンロード ・当初のクラス設計 ・作成するクラスのメンバー一覧 ・全体構成図 ・全プロシージャー・プロパティの一覧 ・全VBAコード
№19 Excel将棋:棋譜ファイルから対局一覧作成
・対局一覧のシート ・Excel将棋の動作 ・全体構成図 ・Excel将棋のダウンロード ・新規追加したVBAコード ・Excel将棋の目次



新着記事NEW ・・・新着記事一覧を見る

ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.並べ替え(Sort)|VBA入門
8.条件分岐(IF)|VBA入門
9.セルのクリア(Clear,ClearContents)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ