Excel将棋：棋譜ファイルから対局一覧作成(№19)
Excelで将棋を作るシリーズの当初目標の、人vs人で動かしてゲームとして成立するところまでは完成しました。
複数の棋譜ファイルも一度に処理できるようにしています。
また、その一覧のファイル名をダブルクリックすることで、棋譜の自動再現も動くようにしました。
・対局一覧シートを追加
・棋譜ファイル（複数可）を読み込み対局一覧を作成
・対局一覧のファイル名ダブルクリックで棋譜を自動再生
・棋譜ファイル（複数可）を読み込み対局一覧を作成
・対局一覧のファイル名ダブルクリックで棋譜を自動再生
対局一覧のシート
以下で、KIFファイルをダウンロードできます。
項目は以下です
開始日時 ・・・ ここのダブルクリックで棋譜の自動再生が始まります。
先手
後手
棋戦
持ち時間
先手の戦型
後手の戦型
先手の手筋
後手の手筋
先手の備考
後手の備考
手合割
手数
先手
後手
棋戦
持ち時間
先手の戦型
後手の戦型
先手の手筋
後手の手筋
先手の備考
後手の備考
手合割
手数
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) < "１" Or Left(sSplit(1), 1) > "９" 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 ・・・新着記事一覧を見る
TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.繰り返し処理（For Next)｜VBA入門
3.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- Excel将棋：棋譜ファイルから対局一覧作成(№19)
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。