Excel囲碁：再起動後も続けて打てるように改造

公開日：2020-08-19　最終更新日：2020-12-29

Excel囲碁：再起動後も続けて打てるように改造

Excelで囲碁を作ってみます。
人vs人で対戦できる程度、単純に黒白交互に打っていけるものです。
前作ではその場で打てればよいだけで作成しましたが、
1日1ツイートで先生とフォロワーで対戦していくことになりました。
そこで、日々初手から打っていくのでは大変なので、前回保存状態から打ち続けられるように改造しました。

前作については以下をご覧ください。

Excel囲碁：万波奈穂先生に捧ぐ

・Excel囲碁の動作・全体の処理流れ・Excel囲碁の全VBAコード・Excel囲碁のダウンロード

ツイッターで日々使っていくので、その過程でさらに改良していくことになると思います。
変更は随時こちらに掲載していく予定です。

更新履歴

更新日	更新内容
2020/8/22	星を付けました。路盤数に一般的な位置に星をつけるようにしています。
2020/8/25	石の上に手数の数字を表示しました。「№消去」でそれまでの手数表示を消すことができます。
2020/12/28	細かいバグ修正と保護解除ボタン追加

以下に掲載のVBAコートおよび、以下のダウンロードは常に更新後の最新にしてあります。
excel_igo2.zip　excel_igo2.xlsm

Excel囲碁の今回の改造のきっかけ

これを作るきっかけとなったのは、
万波奈穂@naonao_myu
こちらの先生のツイート

ツイートはハッシュタグ、
#１日１ツイートで囲碁ルールを説明したら何日で伝えられるか

Excel囲碁の今回の改造点

各種情報を表示し引き継ぎやすいように、
シート内の開始位置は固定にしました。

以下の情報をシートに表示するようにしました。

・路盤数
・手数
・コウ
・棋譜

これにより、ブックを保存し閉じた後でも、再度ブックを開けば続けて打っていくことができるようになりました。
また、シートそのものをコピーすれば、コピー先のシートでも打ち続けられます。
もちろん元のシートでも打ち続けられます。
ただし、「待った」で戻せるのは再開後だけになります。
この辺りは、Excelの「元に戻す」と同じようなものだと考えてください。

さらに追加機能として、
「盤面コピー」を追加しました。
ボタンクリックすると、

ツイッターに「Ctrl + C」で貼り付けできます。

Excel囲碁の全VBAコード


  
    
      Option Explicit


Public Const c碁盤色 = &H75DEFF 'RGB(255, 222, 117)

Public Const c開始位置 = "C2"


Public g路盤数 As Integer '9,13,15,19

Public g碁盤幅 As Long 'ピクセル指定


Public gWS As Worksheet

Public g先手アゲハマ As Range

Public g後手アゲハマ As Range


Public g手数

Public gCols配列

Public gCols先手アゲハマ

Public gCols後手アゲハマ


Public gStrコウ


Enum e碁石

　　無

　　黒

　　白

End Enum


'**********************************************************************

' ゲーム進行の制御メイン

'**********************************************************************


Sub ゲーム開始()

　　Dim inputStr

start:

　　inputStr = InputBox("路盤数を指定してください。" & vbLf & vbLf & _

　　　　　　　　　　　　"続けてカンマ(,)の後ろに1路の幅をビクセルで指定できます。" & vbLf & _

　　　　　　　　　　　　"例．" & vbLf & _

　　　　　　　　　　　　"9" & vbLf & _

　　　　　　　　　　　　"9,60", "碁盤初期設定")

　　If inputStr = "" Then Exit Sub

　　Dim sSplit: sSplit = Split(inputStr, ",")

　　Dim i

　　For i = 0 To UBound(sSplit)

　　　　If Not IsNumeric(sSplit(0)) Then

　　　　　　GoTo start

　　　　End If

　　Next

　　g路盤数 = sSplit(0)

　　If UBound(sSplit) = 0 Then

　　　　g碁盤幅 = 550 / g路盤数

　　Else

　　　　g碁盤幅 = sSplit(1)

　　End If

　　

　　ActiveWindow.DisplayGridlines = False

　　Set gWS = ActiveSheet

　　Dim myRange

　　Set myRange = gWS.Range(c開始位置)

　　

　　Application.ScreenUpdating = False

　　

　　Set gWS = myRange.Worksheet

　　シート設定 myRange

　　引継情報場所

　　アゲハマ場所作成 myRange

　　碁盤座標 myRange

　　碁石作成 myRange

　　星作成 myRange

　　

　　g手数 = 0

　　Set gCols配列 = New Collection

　　Set gCols先手アゲハマ = New Collection

　　Set gCols後手アゲハマ = New Collection

　　gCols配列.Add 配列作成, CStr(g手数)

　　gCols先手アゲハマ.Add "", CStr(g手数)

　　gCols後手アゲハマ.Add "", CStr(g手数)

　　gStrコウ = ""

　　gWS.Range("手番") = "●先手番です"

　　盤面保存

　　

　　Application.ScreenUpdating = True

End Sub


Sub パス()

　　盤面再開

　　g手数 = g手数 + 1

　　gCols配列.Add 配列作成, CStr(g手数)

　　gCols先手アゲハマ.Add g先手アゲハマ.Value, CStr(g手数)

　　gCols後手アゲハマ.Add g先手アゲハマ.Value, CStr(g手数)

　　gWS.Range("手番") = IIf(先手, "◯後手番です", "●先手番です") '次の手番

　　盤面保存

End Sub


Sub 待った()

　　盤面再開

　　If g手数 = 0 Then Exit Sub

　　If Not IsArray(gCols配列(CStr(g手数 - 1))) Then

　　　　MsgBox "これ以上は待ったはできません。"

　　　　Exit Sub

　　End If

　　

　　Dim sp碁石, i, j

　　For Each sp碁石 In gWS.Shapes

　　　　If sp碁石.Name Like "碁石*" Then

　　　　　　碁石Index sp碁石, i, j

　　　　　　Select Case gCols配列(CStr(g手数 - 1))(i, j)

　　　　　　　　Case e碁石.黒

　　　　　　　　　　sp碁石.Fill.Transparency = 0

　　　　　　　　　　sp碁石.Fill.ForeColor.RGB = vbBlack

　　　　　　　　Case e碁石.白

　　　　　　　　　　sp碁石.Fill.Transparency = 0

　　　　　　　　　　sp碁石.Fill.ForeColor.RGB = vbWhite

　　　　　　　　Case e碁石.無

　　　　　　　　　　sp碁石.Fill.Transparency = 1

　　　　　　End Select

　　　　End If

　　Next

　　gCols配列.Remove CStr(g手数)

　　

　　手数再表示

　　

　　g先手アゲハマ.Value = gCols先手アゲハマ(g手数)

　　g後手アゲハマ.Value = gCols後手アゲハマ(g手数)

　　gCols先手アゲハマ.Remove CStr(g手数)

　　gCols後手アゲハマ.Remove CStr(g手数)

　　

　　g手数 = g手数 - 1

　　

　　盤面保存

　　gWS.Range("棋譜").Offset(1).Delete Shift:=xlUp

End Sub


Sub 盤面コピー()

　　盤面再開

　　gWS.Range(c開始位置).Resize(g路盤数 + 1, g路盤数 + 1).CopyPicture Format:=xlBitmap

　　MsgBox "盤面をクリップボードにコピーしました。"

End Sub


Sub 打つ()

　　盤面再開

　　Dim sp碁石: Set sp碁石 = gWS.Shapes(Application.Caller)

　　

　　If 碁石判別(sp碁石) <> e碁石.無 Then

　　　　Exit Sub

　　End If

　　

　　If コウ判定(sp碁石) Then

　　　　Exit Sub

　　End If

　　

　　g手数 = g手数 + 1

　　

　　sp碁石.Fill.ForeColor.RGB = IIf(先手, vbBlack, vbWhite)

　　sp碁石.Fill.Transparency = 0

　　相手碁石確認 sp碁石

　　

　　gCols配列.Add 配列作成, CStr(g手数)

　　gCols先手アゲハマ.Add g先手アゲハマ.Value, CStr(g手数)

　　gCols後手アゲハマ.Add g先手アゲハマ.Value, CStr(g手数)

　　

　　着手禁止点 sp碁石

　　

　　手数表示 sp碁石

　　棋譜追加 sp碁石

　　盤面保存

End Sub


'**********************************************************************

' メインから呼ばれるSubとFunction

'**********************************************************************


Sub 棋譜追加(sp碁石)

　　Dim i, j

　　碁石Index sp碁石, i, j

　　gWS.Range("棋譜").Offset(1).Insert Shift:=xlDown

　　gWS.Range("棋譜").Offset(1) = g手数 & ". " & _

　　　　　　　　　　　　　　　　　StrConv(j, vbWide) & _

　　　　　　　　　　　　　　　　　WorksheetFunction.Text(i, "[DBNum1]0") & _

　　　　　　　　　　　　　　　　　IIf(先手, "●", "◯")

　　gWS.Range("手番") = IIf(先手, "◯後手番です", "●先手番です") '次の手番

End Sub


Sub 盤面保存()

　　With gWS

　　　　.Range("路盤数") = g路盤数

　　　　.Range("手数") = g手数

　　　　.Range("コウ") = "'" & gStrコウ

　　End With

End Sub


Sub 盤面再開()

　　ActiveSheet.Protect UserInterfaceOnly:=True

　　If gWS Is ActiveSheet Then Exit Sub

　　

　　Set gWS = ActiveSheet

　　

　　On Error Resume Next

　　If gWS.Range("手数") = "" Or gWS.Range("路盤数") = "" Then

　　　　MsgBox "情報がありません。" & vbLf & "ゲーム開始からやり直してください。"

　　　　Exit Sub

　　End If

　　If Err Then

　　　　MsgBox "情報がありません。" & vbLf & "ゲーム開始からやり直してください。"

　　　　Exit Sub

　　End If

　　On Error GoTo 0

　　

　　With gWS

　　　　g手数 = .Range("手数")

　　　　g路盤数 = .Range("路盤数")

　　　　Set g先手アゲハマ = .Range("先手アゲハマ")

　　　　Set g後手アゲハマ = .Range("後手アゲハマ")

　　　　gStrコウ = .Range("コウ")

　　End With

　　

　　Set gCols配列 = New Collection

　　Set gCols先手アゲハマ = New Collection

　　Set gCols後手アゲハマ = New Collection

　　

　　Dim i As Long

　　For i = 0 To g手数 - 1

　　　　gCols配列.Add "", CStr(i)

　　　　gCols先手アゲハマ.Add "", CStr(i)

　　　　gCols後手アゲハマ.Add "", CStr(i)

　　Next

　　gCols配列.Add 配列作成, CStr(g手数)

　　gCols先手アゲハマ.Add g先手アゲハマ.Value, CStr(g手数)

　　gCols後手アゲハマ.Add g後手アゲハマ.Value, CStr(g手数)

End Sub


Function 先手(Optional 手数 = 0)

　　先手 = CBool(IIf(手数 = 0, g手数, 手数) Mod 2)

End Function


Function コウ判定(sp碁石)

　　Dim i, j

　　碁石Index sp碁石, i, j

　　If gStrコウ = 文字列Index(i, j) Then

　　　　MsgBox "コウなので打てません。"

　　　　コウ判定 = True

　　　　Exit Function

　　End If

　　gStrコウ = ""

End Function


Sub 着手禁止点(sp碁石)

　　Dim y, x, tValue, rtn

　　碁石Index sp碁石, y, x

　　Dim ary: ary = 配列作成

　　rtn = True

　　相手碁石何奪取 ary, y, x, IIf(先手, e碁石.黒, e碁石.白), rtn

　　If rtn Then

　　　　MsgBox "着手禁止点です。"

　　　　待った

　　End If

End Sub


Sub 相手碁石確認(sp碁石)

　　Dim y, x, ary, tValue, rtn

　　

　　碁石Index sp碁石, y, x

　　tValue = IIf(先手, e碁石.白, e碁石.黒) '相手碁石

　　

　　If y > 1 Then

　　　　ary = 配列作成

　　　　If ary(y - 1, x) = tValue Then

　　　　　　rtn = True

　　　　　　相手碁石何奪取 ary, y - 1, x, tValue, rtn

　　　　　　If rtn Then 相手碁石奪取 ary

　　　　End If

　　End If

　　If y < g路盤数 Then

　　　　ary = 配列作成

　　　　If ary(y + 1, x) = tValue Then

　　　　　　rtn = True

　　　　　　相手碁石何奪取 ary, y + 1, x, tValue, rtn

　　　　　　If rtn Then 相手碁石奪取 ary

　　　　End If

　　End If

　　If x > 1 Then

　　　　ary = 配列作成

　　　　If ary(y, x - 1) = tValue Then

　　　　　　rtn = True

　　　　　　相手碁石何奪取 ary, y, x - 1, tValue, rtn

　　　　　　If rtn Then 相手碁石奪取 ary

　　　　End If

　　End If

　　If x < g路盤数 Then

　　　　ary = 配列作成

　　　　If ary(y, x + 1) = tValue Then

　　　　　　rtn = True

　　　　　　相手碁石何奪取 ary, y, x + 1, tValue, rtn

　　　　　　If rtn Then 相手碁石奪取 ary

　　　　End If

　　End If

End Sub


Sub 相手碁石何奪取(ary, y, x, tValue, rtn)

　　If rtn = False Then Exit Sub

　　ary(y, x) = 9

　　

　　If y > 1 Then

　　　　If ary(y - 1, x) = 0 Then

　　　　　　rtn = False: Exit Sub

　　　　ElseIf ary(y - 1, x) = tValue Then

　　　　　　相手碁石何奪取 ary, y - 1, x, tValue, rtn

　　　　End If

　　End If

　　If y < g路盤数 Then

　　　　If ary(y + 1, x) = 0 Then

　　　　　　rtn = False: Exit Sub

　　　　ElseIf ary(y + 1, x) = tValue Then

　　　　　　相手碁石何奪取 ary, y + 1, x, tValue, rtn

　　　　End If

　　End If

　　If x > 1 Then

　　　　If ary(y, x - 1) = 0 Then

　　　　　　rtn = False: Exit Sub

　　　　ElseIf ary(y, x - 1) = tValue Then

　　　　　　相手碁石何奪取 ary, y, x - 1, tValue, rtn

　　　　End If

　　End If

　　If x < g路盤数 Then

　　　　If ary(y, x + 1) = 0 Then

　　　　　　rtn = False: Exit Sub

　　　　ElseIf ary(y, x + 1) = tValue Then

　　　　　　相手碁石何奪取 ary, y, x + 1, tValue, rtn

　　　　End If

　　End If

End Sub


Sub 相手碁石奪取(ary)

　　gStrコウ = ""

　　Dim sp, i, j

　　For i = LBound(ary, 1) To UBound(ary, 1)

　　　　For j = LBound(ary, 2) To UBound(ary, 2)

　　　　　　If ary(i, j) = 9 Then

　　　　　　　　Set sp = gWS.Shapes("碁石" & Format(i, "00") & Format(j, "00"))

　　　　　　　　sp.Fill.Transparency = 1

　　　　　　　　If 先手 Then

　　　　　　　　　　g先手アゲハマ = g先手アゲハマ & "●"

　　　　　　　　Else

　　　　　　　　　　g後手アゲハマ = g後手アゲハマ & "●"

　　　　　　　　End If

　　　　　　　　gStrコウ = gStrコウ & 文字列Index(i, j)

　　　　　　　　DoEvents

　　　　　　　　Application.Wait [now()+"0:0:0.1"]

　　　　　　End If

　　　　Next

　　Next

　　If Len(gStrコウ) > 4 Then gStrコウ = ""

End Sub


Function 碁石判別(sp碁石) As e碁石

　　Select Case True

　　　　Case sp碁石.Fill.Transparency = 1

　　　　　　碁石判別 = 無

　　　　Case sp碁石.Fill.ForeColor.RGB = vbBlack

　　　　　　碁石判別 = 黒

　　　　Case sp碁石.Fill.ForeColor.RGB = vbWhite

　　　　　　碁石判別 = 白

　　End Select

End Function


Function 配列作成()

　　ReDim ary(1 To g路盤数, 1 To g路盤数)

　　Dim sp碁石, i, j

　　For Each sp碁石 In gWS.Shapes

　　　　If sp碁石.Name Like "碁石*" Then

　　　　　　Call 碁石Index(sp碁石, i, j)

　　　　　　ary(i, j) = 碁石判別(sp碁石)

　　　　End If

　　Next

　　配列作成 = ary

End Function


Sub 碁石Index(sp碁石, i, j)

　　i = CLng(Mid(sp碁石.Name, 3, 2))

　　j = CLng(Mid(sp碁石.Name, 5, 2))

End Sub


Function 文字列Index(i, j)

　　文字列Index = Format(i, "00") & Format(j, "00")

End Function


'**********************************************************************

' ゲーム進行の制御メイン

'**********************************************************************


Sub 手数表示(sp碁石)

　　Dim sp

　　Set sp = gWS.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, sp碁石.Width * 2, sp碁石.Height)

　　sp.Name = "手数" & sp碁石.Name

　　sp.Top = sp碁石.Top

　　sp.Left = sp碁石.Left - (sp碁石.Width / 2)

　　sp.Fill.Visible = msoFalse

　　sp.Line.Visible = msoFalse

　　sp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = IIf(先手(), vbWhite, vbBlack)

　　sp.TextFrame2.TextRange.Characters.Text = g手数

　　Select Case g路盤数

　　　　Case Is <= 9

　　　　　　sp.TextFrame2.TextRange.Font.Size = 20

　　　　Case Is <= 13

　　　　　　sp.TextFrame2.TextRange.Font.Size = 14

　　　　Case Is <= 15

　　　　　　sp.TextFrame2.TextRange.Font.Size = 11

　　　　Case Else

　　　　　　sp.TextFrame2.TextRange.Font.Size = 9

　　End Select

　　sp.TextFrame2.VerticalAnchor = msoAnchorMiddle

　　sp.TextFrame2.HorizontalAnchor = msoAnchorCenter

　　

　　手数再表示

End Sub


Sub 手数再表示()

　　On Error Resume Next

　　Dim sp碁石, sp

　　For Each sp碁石 In gWS.Shapes

　　　　If sp碁石.Name Like "碁石*" Then

　　　　　　Select Case sp碁石.Fill.Transparency

　　　　　　　　Case 1

　　　　　　　　　　gWS.Shapes("手数" & sp碁石.Name).Delete

　　　　　　End Select

　　　　End If

　　Next

　　On Error GoTo 0

End Sub


Sub 手数消去()

　　盤面再開

　　Dim sp

　　For Each sp In gWS.Shapes

　　　　If sp.Name Like "手数*" Then

　　　　　　sp.Delete

　　　　End If

　　Next

End Sub


Sub 保護解除()

　　ActiveSheet.Unprotect

End Sub


'**********************************************************************

' シート作成

'**********************************************************************


Sub シート設定(argRng)

　　argRng.Worksheet.Protect UserInterfaceOnly:=True

　　argRng.Worksheet.Cells.Clear

　　ClearShapes argRng.Worksheet

　　

　　With argRng.Resize(g路盤数 + 1, g路盤数 + 1)

　　　　ColumnWidthPixcel .Cells, CLng(g碁盤幅)

　　　　RowHeightPixcel .Cells, CLng(g碁盤幅)

　　　　.Interior.Color = c碁盤色

　　End With

　　

　　With argRng.Offset(1, 1).Resize(g路盤数 - 1, g路盤数 - 1)

　　　　.Borders.LineStyle = xlContinuous

　　　　.Borders.Weight = xlMedium

　　End With

　　

　　argRng.Worksheet.Protect UserInterfaceOnly:=True

End Sub


Sub 引継情報場所()

　　With gWS

　　　　.Names.Add Name:="手番", RefersToLocal:=.Range("A3")

　　　　.Names.Add Name:="路盤数", RefersToLocal:=.Range("A4")

　　　　.Names.Add Name:="手数", RefersToLocal:=.Range("A5")

　　　　.Names.Add Name:="コウ", RefersToLocal:=.Range("A6")

　　　　.Names.Add Name:="棋譜", RefersToLocal:=.Range("A7")

　　　　.Range("路盤数").NumberFormatLocal = """路盤数：""#"

　　　　.Range("手数").NumberFormatLocal = """手数：""#"

　　　　.Range("コウ").NumberFormatLocal = """コウ：""@"

　　　　.Range("路盤数").HorizontalAlignment = xlLeft

　　　　.Range("手数").HorizontalAlignment = xlLeft

　　　　.Range("コウ").HorizontalAlignment = xlLeft

　　　　.Range("棋譜").Value = "棋譜"

　　End With

End Sub


Sub アゲハマ場所作成(argRng)

　　Set g先手アゲハマ = argRng.Offset(g路盤数, g路盤数 + 1)

　　argRng.Worksheet.Names.Add Name:="先手アゲハマ", RefersToLocal:=g先手アゲハマ

　　アゲハマ場所共通 g先手アゲハマ, vbBlack, vbWhite

　　

　　Set g後手アゲハマ = argRng.Offset(, -1)

　　argRng.Worksheet.Names.Add Name:="後手アゲハマ", RefersToLocal:=g後手アゲハマ

　　アゲハマ場所共通 g後手アゲハマ, vbWhite, vbBlack

　　

　　ColumnWidthPixcel g先手アゲハマ.EntireColumn, CLng(g碁盤幅) * 2

　　ColumnWidthPixcel g後手アゲハマ.EntireColumn, CLng(g碁盤幅) * 2

End Sub


Sub アゲハマ場所共通(argRng, argColor1, argColor2)

　　With argRng

　　　　.Font.Color = argColor2

　　　　.Font.Bold = True

　　　　.WrapText = True

　　　　.Interior.Color = argColor1

　　　　.HorizontalAlignment = xlCenter

　　　　.BorderAround xlContinuous, xlThick, , argColor2

　　End With

End Sub


Sub 碁盤座標(argRng)

　　Dim sp, i

　　For i = 1 To g路盤数

　　　　With 碁盤座標共通(argRng)

　　　　　　.TextFrame2.TextRange.Characters.Text = i

　　　　　　.Top = argRng.Offset(, i).Top - PixcelToPoint(g碁盤幅 / 8)

　　　　　　.Left = argRng.Offset(, i).Left - PixcelToPoint(g碁盤幅 / 2)

　　　　　　.Name = "座標横" & i

　　　　End With

　　　　With 碁盤座標共通(argRng)

　　　　　　.TextFrame2.TextRange.Characters.Text = WorksheetFunction.Text(i, "[DBNum1]0")

　　　　　　.Top = argRng.Offset(i - 1).Top + PixcelToPoint(g碁盤幅 / 2)

　　　　　　.Left = argRng.Offset(i - 1).Left - PixcelToPoint(g碁盤幅 / 8)

　　　　　　.Name = "座標縦" & i

　　　　End With

　　Next

End Sub


Function 碁盤座標共通(argRng)

　　Dim sp

　　Set sp = argRng.Worksheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, PixcelToPoint(g碁盤幅) - 2, PixcelToPoint(g碁盤幅) - 2)

　　With sp

　　　　.TextFrame2.TextRange.Characters.Text = "仮"

　　　　.TextFrame2.TextRange.Characters(1, 1).Font.Size = 11

　　　　.TextFrame2.VerticalAnchor = msoAnchorMiddle

　　　　.TextFrame2.HorizontalAnchor = msoAnchorCenter

　　　　.Fill.Visible = msoFalse

　　　　.Line.Visible = msoFalse

　　　　.Fill.ForeColor.RGB = vbWhite

　　　　.Line.Visible = msoFalse

　　End With

　　Set 碁盤座標共通 = sp

End Function


Sub 碁石作成(argRng)

　　Dim i, j

　　For i = 1 To g路盤数

　　　　For j = 1 To g路盤数

　　　　　　透明碁石作成 argRng, i, j

　　　　Next

　　Next

End Sub


Sub 透明碁石作成(argRng, i, j)

　　Dim sp

　　Set sp = argRng.Worksheet.Shapes.AddShape(msoShapeOval, 0, 0, PixcelToPoint(g碁盤幅) - 2, PixcelToPoint(g碁盤幅) - 2)

　　

　　sp.Fill.Transparency = 1

　　sp.Fill.ForeColor.RGB = vbWhite

　　sp.Line.Visible = msoFalse

　　

　　sp.Top = argRng.Offset(i, j).Top - argRng.Offset(i, j).RowHeight / 2 + 1

　　sp.Left = argRng.Offset(i, j).Left - argRng.Offset(i, j).Width / 2 + 1

　　

　　sp.OnAction = "打つ"

　　sp.Name = "碁石" & 文字列Index(i, j)

End Sub


Sub 星作成(argRng)

　　'天元

　　星作成個別 CInt((g路盤数 - 0.5) / 2) + 1, CInt((g路盤数 - 0.5) / 2) + 1

　　

　　If g路盤数 >= 13 Then

　　　　星作成個別 4, 4

　　　　星作成個別 g路盤数 - 3, 4

　　　　星作成個別 4, g路盤数 - 3

　　　　星作成個別 g路盤数 - 3, g路盤数 - 3

　　End If

　　

　　If g路盤数 = 19 Then

　　　　星作成個別 4, CInt((g路盤数 - 0.5) / 2) + 1

　　　　星作成個別 CInt((g路盤数 - 0.5) / 2) + 1, 4

　　　　星作成個別 g路盤数 - 3, CInt((g路盤数 - 0.5) / 2) + 1

　　　　星作成個別 CInt((g路盤数 - 0.5) / 2) + 1, g路盤数 - 3

　　End If

End Sub

Sub 星作成個別(i, j)

　　Dim sp, wd

　　wd = 0

　　Set sp = gWS.Shapes.AddShape(msoShapeOval, 0, 0, PixcelToPoint(10), PixcelToPoint(10))

　　With sp

　　　　.ZOrder msoSendToBack

　　　　.Fill.Transparency = 0

　　　　.Fill.ForeColor.RGB = vbBlack

　　　　.Line.Visible = msoFalse

　　　　.Top = gWS.Range(c開始位置).Offset(i, j).Top - 3

　　　　.Left = gWS.Range(c開始位置).Offset(i, j).Left - 3

　　　　.Name = "星" & i & j

　　End With

End Sub


Sub ClearShapes(ws)

　　Dim sp

　　For Each sp In ws.Shapes

　　　　If sp.Name Like "碁石*" Or _

　　　　　 sp.Name Like "座標*" Or _

　　　　　 sp.Name Like "星*" Or _

　　　　　 sp.Name Like "手数*" Then

　　　　　　sp.Delete

　　　　End If

　　Next

      End Sub

上記VBAで使っている、
ColumnWidthPixcel
RowHeightPixcel
これらは、前作と同様です。

Excel囲碁：万波奈穂先生に捧ぐ

・Excel囲碁の動作・全体の処理流れ・Excel囲碁の全VBAコード・Excel囲碁のダウンロード

以下の解説ページで紹介しているVBAを使っています。
適当な数値で合わせてしまえば良いのですが、路盤数を自由に設定できるようにしたので、列幅行高もきっちり合うようにしたものです。

列幅・行高をDPI取得しピクセルで指定する

・列幅・行高をピクセルで指定するVBA ・列幅・行高をピクセルで指定するVBAの使い方と解説

Excel囲碁のダウンロード

zipとxlsmを用意しました。

excel_igo2.zip　excel_igo2.xlsm

他のゲーム（数独、オセロ、将棋）も含めたダウンロード一覧は以下になります。

エクセルのサンプルダウンロード

同じテーマ「マクロVBAサンプル集」の記事

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
 他ブックへのリンクエラーを探し解除
 Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
Excel囲碁：再起動後も続けて打てるように改造
エクセルVBAで15パズルを作ってみた
 エクセル麻雀ミニゲーム

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

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

ホーム
マクロVBA応用編
マクロVBAサンプル集
Excel囲碁：再起動後も続けて打てるように改造

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

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

VBAサンプル集
Excel囲碁：再起動後も続けて打てるように改造