사천성 for Excel
이것은
이른바 쓰촨성, 이각취를 Excel 매크로로 만들어 보았습니다.
아직 만들지만, 기본적인 움직임은 할 수 있다고 생각하기 때문에 투고합니다
해결하기가 힘들고 테스트가 덜 되었기 때문에
이상한 곳이 있으면 가르쳐 주면 기쁩니다.
(그리고, 처음부터 막고 있는 문제를 판별하는 능숙한 방법도・・・)
참고한 기사
htps : // m / gtk / ms / ba 720840328185 2cb91
htps : // 코 m / 마사오키 / ms / 3488320842 A9c3f9fc4
h tp // w w. 아사히네 t. 오 r. jp / ~ a x2s-kmtn / re f / 니코 데 / 1f000. HTML
htps : // 코 m/지노지/있어 ms/23 아
코드
Sheet1.cls
Option Explicit
Const 行数 = 8, 列数 = 17
Dim 経路 As Range
Dim 外周 As Range
Dim 盤上 As Range
Dim 状況 As Range
Dim 選択中 As Range
Dim 開始 As Single
Dim 通知 As WshShell
Dim 牌山 As Dictionary
Enum 柄
東 = 0
伏 = 43
End Enum
Private Sub 変数割当()
Set 外周 = Me.Cells.Resize(行数 + 2, 列数 + 2).Offset(1, 1)
Set 盤上 = Me.Cells.Resize(行数, 列数).Offset(2, 2)
Set 状況 = Me.Cells.Resize(1, 1)
Set 通知 = CreateObject("WScript.Shell")
Set 牌山 = CreateObject("Scripting.Dictionary")
End Sub
Sub 初期処理()
Me.Unprotect
変数割当
ActiveWindow.DisplayGridlines = False
Me.Cells.ClearFormats
Me.Cells.Clear
With 外周
.Font.Size = 20
.Interior.Color = rgbWhite
.Font.Color = rgbWhite
.BorderAround xlContinuous
.HorizontalAlignment = xlVAlignCenter
.VerticalAlignment = xlHAlignCenter
.Value = 牌()
.Columns.AutoFit
.Rows.AutoFit
.Value = ""
End With
With 盤上
.Value = 牌()
.Interior.Color = rgbWhite
.Font.Color = rgbBlack
Dim c As Range, p
For Each c In .Cells
p = 牌(Int(牌山.Count / 4))
c.Value = p
牌山.Add 牌山.Count, p
Next
For Each c In .Cells
p = 牌()
c.Value = p
Next
For Each c In .Cells
p = 引牌(牌山)
c.Value = p
Next
End With
状況更新
開始 = Timer
Me.Protect
End Sub
Private Property Get 残対子数()
If 盤上 Is Nothing Then 変数割当
残対子数 = WorksheetFunction.CountA(盤上) / 2
End Property
Private Sub 状況更新()
Me.Unprotect
状況.Value = 残対子数 & " Pairs Left"
Me.Protect
End Sub
Private Function 引牌(dic As Dictionary)
Dim k
k = dic.Keys(WorksheetFunction.RandBetween(0, dic.Count - 1))
引牌 = dic(k)
dic.Remove k
End Function
Private Function 牌(Optional c As 柄 = 伏)
If c < 東 Or c > 伏 Then c = 伏
c = c + 61440
牌 = ChrW(&HD800 + Int(c / &H400)) & ChrW(&HDC00 + CInt(c And &H3FF))
End Function
Private Function 経路取得(p1 As Range, p2 As Range) As Range
If 外周 Is Nothing Then 変数割当
If p1 Is Nothing Or p2 Is Nothing Then Exit Function
If Intersect(p1, 外周) Is Nothing Or Intersect(p2, 外周) Is Nothing Then Exit Function
Dim rt As Range, cnt As Long
Dim ec As Range, r As Range, c1 As Range, c2 As Range
Set ec = Intersect(外周, Range(p1, p2).EntireColumn)
For Each r In ec.Rows: DoEvents
Set c1 = Range(p1, Cells(r.Row, p1.Column))
Set c2 = Range(p2, Cells(r.Row, p2.Column))
Set rt = Union(c1, r, c2)
If WorksheetFunction.CountA(rt) = 2 Then
If cnt = 0 Or rt.Count < cnt Then
cnt = rt.Count
Set 経路取得 = rt
End If
End If
Next
Dim er As Range, c As Range, r1 As Range, r2 As Range
Set er = Intersect(外周, Range(p1, p2).EntireRow)
For Each c In er.Columns: DoEvents
Set r1 = Range(p1, Cells(p1.Row, c.Column))
Set r2 = Range(p2, Cells(p2.Row, c.Column))
Set rt = Union(r1, c, r2)
If WorksheetFunction.CountA(rt) = 2 Then
If cnt = 0 Or rt.Count < cnt Then
cnt = rt.Count
Set 経路取得 = rt
End If
End If
Next
End Function
Private Function 可否(p1 As Range, p2 As Range) As Boolean
If Not 同一(p1, p2) Then Exit Function
Set 経路 = 経路取得(p1, p2)
可否 = Not 経路 Is Nothing
End Function
Private Function 同一(p1 As Range, p2 As Range)
If IsEmpty(p1) Or IsEmpty(p2) Then Exit Function
同一 = p1.Value = p2.Value 'TODO:花牌処理
End Function
Private Function 選択(p1 As Range)
Me.Unprotect
Set 選択中 = p1
選択中.Interior.Color = vbCyan
Me.Protect
End Function
Private Function 選択解除()
Me.Unprotect
If 選択中 Is Nothing Then Exit Function
選択中.Interior.Color = rgbWhite
Set 選択中 = Nothing
Me.Protect
End Function
Private Function 詰み判定(Optional c As Range) As Boolean
If 盤上 Is Nothing Then 変数割当
For Each c In 盤上
If 探索(c) Then Exit Function
Next
詰み判定 = True
End Function
Private Function 探索(ByVal Target As Range) As Boolean
Dim c As Range
If 盤上 Is Nothing Then 変数割当
For Each c In 盤上
If Not Target.Address = c.Address Then 探索 = 可否(Target, c)
If 探索 Then Exit Function
Next
End Function
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Me.Unprotect
Cancel = True
Dim c As Range
If 盤上 Is Nothing Then 変数割当
If Intersect(外周, Target) Is Nothing Then
If Not 詰み判定(c) Then c.Select
Exit Sub
End If
If Target.Value = "" Then
選択解除
Exit Sub
End If
For Each c In 盤上
If Not c.Address = Target.Address Then
If 同一(Target, c) Then c.Interior.Color = vbYellow
If 可否(Target, c) Then c.Interior.Color = vbCyan
End If
Next
盤上.Interior.Color = rgbWhite
Target.Interior.Color = vbCyan
Me.Protect
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then
ActiveCell.Select
Exit Sub
End If
If 選択中 Is Nothing Then
If Target.Value = "" Then Exit Sub
選択 Target
Else
If 可否(選択中, Target) Then
Me.Unprotect
With 経路
.Interior.Color = vbCyan
.ClearContents
.Interior.Color = rgbWhite
End With
状況更新
If 残対子数 = 0 Then
通知.Popup Timer - 開始, 3, "CLEAR"
初期処理
ElseIf 詰み判定() Then
通知.Popup "詰んだかも・・・", 3, "NOT CLEAR"
End If
Me.Protect
Else
選択解除
Worksheet_SelectionChange Target
End If
End If
End Sub
Reference
이 문제에 관하여(사천성 for Excel), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다 https://qiita.com/jinoji/items/5fca9745371aaf73644f텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념 (Collection and Share based on the CC Protocol.)