以下の説明は、ナンバープレイスの解き方(ＶＢＡ初級編）として、ＥＸＣＥＬで作成したものです。
ご希望の方には、メールを頂ければ 差し上げます。 匿名でも結構ですが、差支えが無かったら、氏名、住所、年齢、性別、職業の記入をお願いいたします。
基本的なルールは
①縦９列のどの列にも１～９の数字が一つずつ入る。
②横９行のどの行にも１～９の数字が一つずつ入る。
③太線で囲まれた３ｘ３＝９マスの、どのプロックにも１～９の数字が一つずつ入る。
例題として スタンダード（標準）のものをあげていますが、これをＶＢＡでは変則ブロック（又はジグザク）として扱っています。 つまり、変則の形が３ｘ３の正方形のときが スタンダード だと考えています。 背景の色が同じものを同じグループとしています。
この例題はナンバープレイス(英知出版）の１１月号に掲載されています。 雑誌の説明との違いを知るのも面白いかと思います。
では、実際に解いてみましょう。
まず、次のようなデータを シート＜例＞に作成します。
上記のように 作成したら、メニューの「ツール」－「マクロ」－「マクロ」と選択し、マクロ名から＜初級編＞を選んで実行します。 そうすると、マクロが実行されて、現在のシートが次のようになります。
左の表のマスに 赤い数字が表れ 今回のマクロの実行で埋められたことを意味しています。
右の表は、マクロの実行時の作業の中身を示す作業領域となります。 左の表 セルＤ３（座標の数値はシート＜例＞でのものです） は 右の表 セルＰ３に 対応しており、セルＬ３は セルＸ３に対応しています。 以下 セルＬ１１ は セルＸ１１に対応しています。
では、左の表の セルＤ３ と 右の表の セルＰ３ を見てみます。
セルＤ３ は空欄のままですが、 セルＰ３ には ７，９ と表示されています。
つまり、現在の段階では このセルＤ３ には ７と９の両方の数が入る可能性があるということです。
①の縦 のルールから ２、３、５、７、９ の５つの数字が入る可能性があります。
更に ②の横 のルールから ４、５、６、７、９ の数字が入る可能性がありますが、①とあわせるとこの中から４と６は削除され ５、７、９ の３つの数字に減ります。
更に ③のブロック のルールから ２、３、４、７、９ の数字が入る可能性がありますが、結局 ７と９だけが残ります。
このようにして、左の表の空欄のマスを全部みていくと、右の表が作成されます。
右の表の セルの中で 数字が１つしかないものは 確定 ということになり、残されている数字が左の表に 赤で表示されます。
このままで、前と同じように マクロから初級編を実行すると、また次のように変化します。
このままで、さらに マクロから初級編を実行すると、また次のように変化します。
このままで、さらに マクロから初級編を実行すると、また次のように変化します。
このままで、さらに マクロから初級編を実行すると、また次のように変化します。
５回目で完成しました。
それではまず、実際の シート＜例＞ を使って、上記と同様になることを確認してください。
もし、間違ってシートを壊してしまった時は、原本から 復旧してください。
確認しましたら、更に シート＜Ｑ２＞でも実行してみてください。
最後に シート＜Ｑ５８＞です。 これは 本来の変則ブロックです。
人間にとっては、このようにブロックが変形であると、解析の方法が大分違ってきますが、ＶＢＡでやると、まったくスタンダードと同じくなります。
なお、今回のものは あくまで初級編です。 難度が高くなると、これだけではとても解析はできません。 更に上を試してみたい方は メールで 御連絡ください。
最後に、これより難度が高いものでも これだけのマクロで対応できる場合があります。
そのヒントを紹介しておきましょう。
右の表を最大限に利用することです。
現在は、左の表には 最初だけしか入力しませんでしたが、右の表を見れば、ある程度解析を自分で行えます。 確実だと思ったら、左の開いているマスを自分で埋めてみてください。
そうして、マクロを実行すれば かなり難度の高いものでも 解析できる場合が少なくありません。
ご健闘を祈ります。
以下に、マクロのコードを公開します。 参考になれば幸いです。
Sub 初級編()
'======================================================
Dim AidaClm As Integer
Dim cuColor As Integer
Dim ffCalClm As Integer
Dim ffClm As Integer
Dim ffRow As Integer
Dim Kosu As Integer
Dim offClm As Integer
Dim offRow As Integer
Dim PageCnt As Integer
Dim tbl(25, 25) As Integer
Dim Temp As String
Dim ttCalClm As Integer
Dim ttClm As Integer
Dim ttRow As Integer
If ActiveSheet.Name = "原本" Then
MsgBox "原本では処理できません"
Exit Sub ' --->
End If
Kosu = Range("B4")
Syurui = Range("F1")
offClm = 3
offRow = 2
ffClm = offClm + 1
ttClm = offClm + Kosu
ffRow = offRow + 1
ttRow = offRow + Kosu
AidaClm = 3
ffCalClm = ttClm + AidaClm + 1
ttCalClm = ffCalClm + Kosu - 1
' 初期データを取り込む
yy = 0
For wkrow = ffRow To ttRow
yy = yy + 1
xx = 0
For wkclm = ffClm To ttClm
xx = xx + 1
tbl(yy, xx) = Cells(wkrow, wkclm)
Next
Next
'作業セルをクリアする
Range(AlphCnv(ffCalClm) & CStr(ffRow) & ":" & AlphCnv(ttCalClm) & CStr(ttRow)).Select
Selection.ClearContents
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True ' 折り返して全体を表示
End With
With Selection.Font
. Size = 11
.ColorIndex = 3
End With
For wkrow = ffRow To ttRow
yy = wkrow - offRow
For wkclm = ffClm To ttClm
xx = wkclm - offClm
If Cells(wkrow, wkclm) = 0 Then '未確定
Cells(wkrow, wkclm).Select
cuColor = Selection.Interior.ColorIndex
ReDim wkFlg(Kosu) As Boolean
'行を調べる
For jj = 1 To Kosu
If tbl(yy, jj) Then
wkFlg(tbl(yy, jj)) = True
End If
Next
'列を調べる
For jj = 1 To Kosu
If tbl(jj, xx) Then
wkFlg(tbl(jj, xx)) = True
End If
Next
'グループ(セルの書式のパターンが同じ色）を調べる
For jj = ffRow To ttRow
For kk = ffClm To ttClm
Cells(jj, kk).Select
If Selection.Interior.ColorIndex = cuColor Then
If ActiveCell Then
wkFlg(ActiveCell) = True
End If
End If
Next
Next
’作業セルに表示する
Temp = ""
c1 = 0
For jj = 1 To Kosu
If wkFlg(jj) = False Then
c1 = c1 + 1
cjj = jj
If Temp <> "" Then Temp = Temp + ","
Temp = Temp & jj
End If
Next
Cells(wkrow, wkclm + Kosu + AidaClm).Select
ActiveCell = Temp
If c1 = 1 Then
'１個しかない時は確定とする
Selection.Font.ColorIndex = 3
Cells(wkrow, wkclm) = cjj
End If
Else ’確定
If Cells(wkrow, wkclm + Kosu + AidaClm) = 0 Then
Cells(wkrow, wkclm + Kosu + AidaClm).Select
ActiveCell = Cells(wkrow, wkclm)
Selection.Font.ColorIndex = 41 ' 青
Selection.Font.Size = 22
Selection.HorizontalAlignment = xlCenter
End If
End If
Next
Next
MsgBox "処理終了"
End Sub
Function AlphCnv(xNm)
'=========================================================================
If xNm <= 256 Then ’列は最大 ＩＶ まで
AxNm1 = Int((xNm - 1) / 26)
AxNm2 = xNm Mod 26
If AxNm2 = 0 Then AxNm2 = 26
If AxNm1 Then
Alph = Chr(AxNm1 + 64)
Else
Alph = ""
End If
AlphCnv = Alph + Chr(AxNm2 + 64)
Else
MsgBox "最大値を越えている"
AlphCnv = True
End If
End Function
