どうでもいいプログラム研究所

とある編集者によるIT、Web、ソフトウェア、プログラミングに関する雑記と覚え書き

ワークシート上のフォームコントロールはどうやって取得する?【VBA】

最近書いた「サクラクレパスクーピーの柄をランダムに生成するExcelマクロを考えてみた」の続きです。ワークシート上でフォームコントロールの図形を扱っていたときに少し引っかかった話です。

フォームコントロールのボタンが消えてしまった

このクーピー柄生成マクロを作っている際に、シート上に生成した図形をすべて消すため、以下のマクロを書きました。

Sub deleteAll()
   Dim shp As Shape
   For Each shp In ActiveSheet.Shapes
      shp.Delete
   Next shp
End Sub

見ておわかりの通り、アクティブなシート上に存在する図形をすべて消去するマクロです。このマクロをフォームコントロールのボタンに登録し、そのあとボタンを押して実行したのですが、

押したボタンまで消えてしまった……

まあ「そんなの当たり前だろ」って話なのですが、Shapeオブジェクト=オートシェイプくらいの認識しかなかった私は、このとき初めて「フォームコントロールもShapeオブジェクトに含まれるのか…」と思ったわけです。 

ではフォームコントロールをどうプログラムに識別させる? 

というわけで、deleteメソッドで図形のうちボタンだけを消去せずに残す対策を考えることに。Shapeオブジェクトのプロパティの中に、必ずフォームコントロールであることを指定するプロパティがあるはずなので、それを探すことにしました。

繰り返しますが、私の中でShapeオブジェクトはオートシェイプのイメージしかなかったので、当初このフォームコントロールを探すのに、AutoShapeTypeプロパティのどれに該当するのかなーという発想になり、それを探してました。ちなみに以下が公式リファレンスです。

docs.microsoft.com

当然、該当するものは見つかりません…

フォームコントロールはTypeプロパティで指定する

その後、ある人のブログを見てようやく判明。Shapeオブジェクトには、Typeプロパティというのがあって、そこでAutoShape以外のShape(例えば画像とかフォームコントロールとかテキストボックスとか)の種類を指定できるのですね。ちなみに以下が公式リファレンスです。

docs.microsoft.com

 

 今回探していたフォームコントロールmsoFormControlでと書くようです。というわけで最初に紹介したマクロは以下のように修正するのがよいでしょう。

Sub deleteAll()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
      If shp.Type <> msoFormControl And shp.Type <> msoPicture Then
      shp.Delete
      End If
    Next shp
End Sub

こうすれば、ボタンは消去されません。あと今回のクーピー柄生成マクロでは、柄の上にクーピーの商品名が書いてある画像ファイルを貼り付けてあり、それも消去の対象から外したいので、それも上記コード中に書いてあります。画像はmsoPictureというType名です。

まぁ「オートシェイプだけを消す」という目的なら

If shp.type = msoautoshape 

と書いて、「オートシェイプに該当したら消去」というロジックでもいいんですけどね。

以上、Shapeオブジェクト=オートシェイプと恥ずかしい思い込みをしていた私のちょっとした失敗談でした。

JavaScriptでポーカーの役を判定するプログラムを書いてみた

f:id:tdyu5021:20191011031708j:plain

タイトルの通り、ポーカーの役を判定するプログラムをJavaScriptで考えてみました。実はこのネタは、以前このブログでExcel VBAバージョンで書いたのですが、JavaScriptでは別の書き方ができるのではと思い実験してみました。

実際のプログラムは以下の通り

実際書いてみたプログラムは以下です。

 

function poker(){
var hands;
var isFlush = true;
var isStraight = true;
var isRoyalStraight = false;

//二次元配列を作って適当に手札を作る(数字とスーツの組み合わせを格納する)
//s:スペード/h:ハート/c:クローバー/d:ダイヤ
var arr = new Array();
arr = [
  {suit:"s",num:12},
  {suit:"d",num:13},
  {suit:"h",num:11},
  {suit:"s",num:1},
  {suit:"d",num:10}
];

//ソート
arr.sort(function(a,b){
  if(a.num<b.num) return -1;
  if(a.num > b.num) return 1;
  return 0;
});

//フラッシュとストレートかを判定
for(var i = 0; i<arr.length-1; i++){
  flg1 = (arr[i].suit == arr[i+1].suit);
  flg2 = ((arr[i+1].num - arr[i].num) ==1);
  if(!flg1) isFlush = false;
  if(!flg2) isStraight = false;
  }
  isRoyalStraight = (arr[0].num==1&&arr[1].num==10&&arr[2].num==11&&arr[3].num==12&&arr[4].num==13);

  //すべて判定
if(isFlush) {  
  hands ="Flush";
  if(isStraight) hands ="StraightFlush";
  if(isRoyalStraight) hands ="RoyalStraightFlush";
  return hands;
}else{
  if(isStraight||isRoyalStraight) {
    return hands = "Straight";
  }else{
      var cnt =0;
      for(var max = 3; max>=0; max--){
        var i = 3 -max; 
        for(var j=1; j<=max+1; j++){
          if(arr[i].num==arr[i+j].num) cnt++;
        }
      }
      switch(cnt){
        case 6:
          return hands= "FourCards";
        case 4:
          return hands= "FullHouse";
        case 3:
          return hands= "ThreeCards";
        case 2:
          return hands= "TwoPairs";
        case 1:
          return hands= "OnePair";
        default:
          return hands = "NoPair";
      }    
  }
}
}

このプログラムでは、成立した役名の文字列を返すようにしています。上記のサンプルコードだとストレートが成立するので、関数を実行すると、”Straight”という文字列が返るようになっています。以下、手順と要点です。 

手札の数字とスーツを配列に格納

本来ならランダムに生成させるのですが、上記のコード内では取り急ぎ決め打ちで入れています。スーツと数字を二次元配列で管理しています。ここはVBAと違って本当に楽ですね~。

手札を昇順にソートする

役を判定するにはまず手札をソートする必要がありますが、JavaScriptには標準でソートのメソッドがあるので非常に楽です。これを知ったときはちょっと感動しました(当然ながらVBAでは用意されていないので。なので誰かがWebに上げてたクイックソートをコピペして使いました)

といいつつ、私はまだこのSortメソッドの使い方を知らず、以下の記事をみてコピペしただけですので、まぁまた必要なときに勉強します・・・

qiita.com

最初にフラッシュとストレートを判定するフラグを立てる

フラッシュやストレートを判定するロジックをif文の条件式の中に組み込んでもよいのですが、そうすると煩雑になりそうなので、

isFlush
isStraight
isRoyalStraight

などの変数を設け、フラッシュやストレートが成立するかを予め格納しておきました。

フラッシュ、ストレート以外の 判定

ここはVBA編で書いたものと同じロジックですので詳しくはVBA編を参照してください。当初、JavaScriptで別の書き方がないかなぁと思って探し、一応候補になるものはあったのですが、そんなに記述量を減らせるわけではなさそうだったので、以前書いたものに落ち着きました。

 

以上です。フラッシュとストレート以外の判定の部分、もっと短く書けるスマートな書き方はないものだろうか。

 

サクラクレパスクーピーの柄をランダムに生成するExcelマクロを考えてみた

f:id:tdyu5021:20191010014617p:plain

おそらく誰もが触ったことのあるサクラクレパス社のクレヨンのクーピー。カラフルな柄のパッケージデザインでおなじみですが、これをExcelで自動生成するというくだらないマクロを考えたので、その過程を書いてみたいと思います。

どんなExcelマクロ?

先日ツイートした以下の内容をご覧ください。文字通り、Excelの図形オブジェクトを使ってクーピーの模様っぽいものをランダムに生成するというしょーもないマクロです。

ちなみに、正式な模様は以下です。

 f:id:tdyu5021:20191010015418j:plain

見ての通り、実際はもっと鮮やかでちゃんと練られているデザインですね。 

なぜ作ったのか?

ぶっちゃけ特に意味はありません。4歳になる息子がよくお絵かきをするのにクーピーを使っているのですが、そのパッケージを何気なくを見ていたときに、「これ、柄のパターンに法則がある!プログラミングで生成できるかも!?」とふと思ったのがきっかけです。

というわけで、生成する要件を考えてみる

パターンに法則がある、というふうに書きましたが、正確には生成するロジックがある程度決まっているということですね。ざっと見たとき、以下のことが言えそうです。f:id:tdyu5021:20191010015754p:plain

よし、これなら簡単そうだ。というわけでVBAで作ってみました。

作り方

最後にソースコードは載せますので、ここではポイントだけ載せておきます。

図形描画のために必要な変数をセット

基本ですが変数を以下のように定義しました。leftPositionは図形の左端の位置。topPositionは図形の上端の位置です。

f:id:tdyu5021:20191010020018p:plain

図形に色を当てるための関数を用意しておく

図形にはランダムに色を付ける必要があるのでそのために以下の関数を作りました。ランダムにR、G、Bの値を生成し、それを配列として返すようにします。

Function createRGB() As Variant
    Dim r As Integer, g As Integer, b As Integer
    Dim arr As Variant
    Randomize
    r = Int(Rnd * 256)
    g = Int(Rnd * 256)
    b = Int(Rnd * 256)     
    arr = Array(r, g, b)
    createRGB = arr
End Function

縦に並んだ2つの棒を作る

以下の通りです。図形を生成するのは、ShapesオブジェクトのAddShapeメソッドです。引数は、1:図形の種類、2:最左端の位置、3:最上端の位置、4:幅、5:高さです。最後に先程生成した色をFillプロパティで適用します。

'//RGB値を取得
arr = createRGB
'//上の棒を生成(※jはループのためのカウンタです)
Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition, Width:=lineWidth, Height:=upperHeight)
'//線はオフ
s.Line.Visible = msoFalse
'//取得した色を当てはめる
s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))


'//以下は下の棒を生成するもの。上とほぼ同じなので省略 
arr2 = createRGB
Set s2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), _Top:=topPosition + upperHeight, Width:=lineWidth, Height:=lowerHeight)
s2.Line.Visible = msoFalse
s2.Fill.ForeColor.RGB = RGB(arr2(0), arr2(1), arr2(2))

上下の2つの棒を区切るサブ図形を生成する

上下にある2つの棒を区切る小さな図形(サブ図形:丸と三角形と四角形)を生成します。これは違うプロシージャ(createSubShape)に書いたので、メインのプロシージャから、引数とともにCallで呼び出します。サブ図形の種類については、ランダムな数字を生成してそれを渡します。本マクロでは0:丸、1:三角形、2:四角形です。

Call createSubShape(leftPosition2, upperHeight, n)
'//第1引数:左端の位置、第2引数:上の棒の長さ、第3引数:図形の種類

サブ図形についての生成については、AddShapeメソッドで図形を生成し、引数で図形の種類、上端の位置、図形の高さを決めて、色を塗って・・・とやることは一緒なので省略します。少しだけ計算が面倒だったのが正三角形の上端の位置の算出です。参考までに以下に書いておきます。

f:id:tdyu5021:20191010020916p:plain

ちなみに、このクーピーの模様では三角形が逆向きになることもあります。これもランダムに発生させます。そのために、まずランダムな数字(0か1)を生成させ、もし0が出たら図形をひっくり返すという風にしています。図形をひっくり返すには、ShapeオブジェクトのFlipメソッドを用い、引数を msoFlipVerticalにします。

どんな図形ができたか!?

上記の図形生成を、Forループで左端の位置をずらしながら実行しました。そうすると以下のような模様ができ上がります。さあどうだ!!

f:id:tdyu5021:20191010021200p:plain

 えっ・・・なんか微妙・・・・

 

なんか不自然ですね・・・これでは本家本元のかわいらしいクーピーの模様に到底及びません!! 

ということで改善方法を考えてみました。

何がおかしいのか?

図形の位置や色を一切の条件なしにランダム生成すると変な模様ができてしまうので、原因を考え、ある程度ランダム化に制限を設けることにしました。その制限が以下のものです。

f:id:tdyu5021:20191010021515p:plain

確かに、クーピーの模様をよく見てみると、

①上の棒と下の棒の長さ関係は列ごとによって結構ばらついている
②サブ図形は同じものが隣り合っていない
③地味な色が少ない

ということがわかります。というわけで①に関しては、前回の列の長さを記憶してそれと比較し、サブ図形の高さの1.5倍分以上は離れるようにしました。②に関しても前回の図形と比較して、同じ図形が出ないようにすればOKです。

残る③の地味な色避ける方法ですが、これを厳密に調整するのは困難なので、「最低限、無彩色に近い色(白、黒、灰色)は避ける」という方向にしました(※ただ実際の模様には、黒っぽい無彩色はあるみたいですけど)

ちなみに無彩色に近い色というのは、簡単にいうとR、G、B各数値が同じような値の色です。例えばRGB(100,110,102)とかで色を調べてみてください。緑味の灰色で地味な色ができます。

今回、完全に地味な色は排除しきれないものの、取り急ぎ以下のロジックを作りました。

(1)R、G、Bの各数値をランダムに生成する
(2)RとG、GとB、BとRの各数値の差の絶対値を調べる
(3)それら3つの絶対値を全部足して90以下だったら、R、G、Bのどれか1つをランダムに選んで数値を100上げるor下げる

こうすれば明らかに白、黒、灰色っぽい色は生成されなくなります。

でき上がり!

この設定変更を加えたマクロを実行すると、例えば以下のような図形が生成されます。どうでしょうか!?先程よりはだいぶ良くなったでしょうか!?

f:id:tdyu5021:20191010021948p:plain

正直なところ、本家本元のデザインには全然及びませんが、まぁ最初よりはマシになったといえるでしょう。 

ただ、このマクロはまだ難点が残っており、上の棒と下の棒、または棒とサブ図形、または列同士で似たような色相の色が隣り合ってしまいます。

これはR、G、Bの中で最も数値が高い色を調べることで、似たような色相が隣にできてしまうことは回避できるのですが、もうめんどくさいのでこれはやりませんでした。

というわけで以上、全く実用性のないお遊びマクロの解説でした。最後に、今回作成したマクロのソースコードを以下に載せておきます。以下のコードをコピペしてdrawプロシージャを実行すれば動くはずです。

Dim topPosition As Integer
Dim maxHeight As Integer
Dim prevHeight As Integer
Dim lineWidth As Integer
Dim leftPosition As Integer
Dim num As Integer
Sub draw()
deleteAll
flg = False
topPosition = 105 '//図形の一番上の位置
maxHeight = 400 '//図形の縦の長さ
prevHeight = 0
lineWidth = 50
leftPosition = 0
num = 0
Call test
End Sub
Sub test()
    Dim arr As Variant
    Dim s As Shape, s2 As Shape
    Dim upperHeight As Integer, lowerHeight As Integer
    Dim prevHeight As Integer
    
    Randomize

    For j = 0 To 15

        Do
        upperHeight = Int(Rnd * maxHeight)
            '//短すぎたり長すぎたりしたらやり直し
            If upperHeight < lineWidth Or upperHeight > maxHeight - lineWidth Then
                flg = True
            Else
                If Abs(upperHeight - prevHeight) > (lineWidth * 1.5) Then
                    flg = False
                Else
                    flg = True
                End If
            End If
        Loop Until flg = False
        '//前回の高さを記憶しておく
        prevHeight = upperHeight
        
        '//下の方の長方形の長さを定義
        lowerHeight = maxHeight - upperHeight
        
        arr = createRGB
        Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition, Width:=lineWidth, Height:=upperHeight)
        s.Line.Visible = msoFalse
        s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))
        
        arr2 = createRGB
        Set s2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition + upperHeight, Width:=lineWidth, Height:=lowerHeight)
        s2.Line.Visible = msoFalse
        s2.Fill.ForeColor.RGB = RGB(arr2(0), arr2(1), arr2(2))
        
        Dim n As Integer
        flg2 = False
        Do
            n = Int(Rnd * 3)
            If n = prev Then
                flg2 = False
            Else
                flg2 = True
            End If
        Loop Until flg2 = True
        
        prev = n
        Dim leftPosition2 As Integer
        leftPosition2 = leftPosition + (j * lineWidth)
        Call createSubShape(leftPosition2, upperHeight, n)
    Next j
End Sub
Function createRGB() As Variant
    Dim r As Integer, g As Integer, b As Integer
    Dim arr As Variant
    Randomize
    r = Int(Rnd * 256)
    g = Int(Rnd * 256)
    b = Int(Rnd * 256)
    
    '//RGBそれぞれの差を見てどれも同じような数値だった場合、
    '//RGBどれか1つの数値を上げる(または下げる)
    diff1 = Abs(r - g)
    diff2 = Abs(r - b)
    diff3 = Abs(b - g)
    
    If (r + g + b) / 3 > 128 Then
        tmp = -1
    Else
        tmp = 1
    End If
     If diff1 + diff2 + diff3 < 90 Then
        'MsgBox (r & "と" & g & "と" & b & " " & num)
        Dim i As Integer
        i = Int(Rnd * 3)
        Select Case i
            Case 0
                r = r + (100 * tmp)
            Case 1
                g = g + (100 * tmp)
            Case 2
                b = b + (100 * tmp)
        End Select
    End If
        
    arr = Array(r, g, b)
    createRGB = arr

End Function
Sub createSubShape(ByVal ml As Integer, ByVal uh As Integer, ByVal i As Integer)
    Dim s As Shape
    Dim halfHeight As Integer
    halfHeight = lineWidth / 2
    arr = createRGB
    
    Select Case i
    Case 0
        Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, ml, topPosition + uh - halfHeight, lineWidth, lineWidth)
    Case 1
        Dim h As Variant
        h = lineWidth / 2 * Sqr(3)
        Set s = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, ml, topPosition + uh - h, lineWidth, h)
        Randomize
        Dim n As Integer
        n = Int(Rnd * 2)
        If n = 0 Then
            s.Flip msoFlipVertical
            s.Top = uh + topPosition
        End If
    Case 2
        Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ml, topPosition + uh - halfHeight, lineWidth, lineWidth)
    End Select

    s.Line.Visible = msoFalse
    s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))
    
End Sub
Sub deleteAll()
  Dim shp As Shape

  For Each shp In ActiveSheet.Shapes
    If shp.Type <> msoFormControl And shp.Name <> "topRect" Then
    shp.Delete
    End If
  Next shp

End Sub

Excel VBAでポーカーの役を判定するプログラムを書いてみた

f:id:tdyu5021:20201120211202p:plain

以前、Excel VBAExcelのワークシートを使い、ゲームセンターによく置いてある「ビデオポーカー」を再現してみました。それについては後々このブログで書きたいなと思いますが、その前にポーカーのプログラムを作成する上で最も重要な「役を判定する」部分をどう作ったのかを紹介したいと思います。

はじめに

作ったきっかけは私がゲームセンターのポーカーが好きだったから。プログラミングの勉強の一環として作ってみたいなと思いました。ポーカーの役を判定するアルゴリズムを以前ネットで調べてみたのですが、自分が使える言語での解説はなく読み解くのも大変なので、完成度はどうあれ自分で作ってみることにしました。

役を判定する方法の概要

初心者なりに私が考えた方法は以下です。

  1. まず重複させないように、ランダムに「数字+絵柄」の組み合わせを5つ作る(手札は5枚だから)
  2. 5枚の数字だけを格納する1次元配列を作る・・・(A)
  3. 5枚の絵柄を格納する1次元配列を作る・・・(B)
  4. (A)の配列をソートして昇順に並び替えておく
  5. (B)を用いて、まずフラッシュが成立するかを判定する
  6. フラッシュが成立すれば、ロイヤルフラッシュかストレートフラッシュか、フラッシュかを判定する
  7. フラッシュが成立しなければその他を判定する

ポーカーに限らず、そもそもトランプを使ったゲームのプログラムを作るとき「数字」と「絵柄(スート)」の2つの情報をどう管理するのかベストなのかはいつも疑問に思っていました。数字とスートをまとめた2次元配列を作ればよいのかなと思っていたのですが、今回は数字と絵柄を違う配列にわけることにしました。

その理由はVBAだと2次元配列の操作や管理が面倒だから。多分ほかの言語でやるならこのように2つの配列には決して分割しないでしょうね。

数字の配列(A)と絵柄の配列(B)と2つの配列を作ると、Aの方だけソートしてBをソートしなければ、最初の手札の数字と絵柄の対応が崩れてしまうため、一見不便に思います。

ですが、実際に絵柄の配列の方はフラッシュが成り立つかどうか(=5枚の絵柄がすべて同じか)だけにしか使いませんし、実際ポーカー全体のプログラムを作る上でもこの実装方法でもまったく支障はありませんでした。

役を判定する方法の詳細な解説

実際に1つずつ見ていきます。

5つの「数字+絵柄」を作る方法

まず以下のような2次元配列を作っておきます。これで4×13の二次元配列すべてにTrueが入ります。

For i = 0 To 3
   cardArray2(i) = Array(True, True, True, True, True, True, True, True, True, True, True,   True, True)
Next i

これは「数字+絵柄」の組み合わせをランダムに生成させたとき、一度生成したものをフラグオフしておくことで重複させないようにするための配列です。絵柄の順番はスペード、ハート、クローバー、ダイヤです。例えば、ランダムに数字と絵柄を生成し、スペードの1が出たらcardArray2(0)(0)をFalseに、ハートの2が出たらcardArray2(1)(1)をFalseにするというふうに操作します。

 

実際にランダムに数字と絵柄を生成するのは以下の処理です。

Do Until j = 5
    n1 = Int(Rnd * 4) '//←ランダムに絵柄を生成(0:スペード/1:ハート/2:クローバー/3:ダイヤ)
    n2 = Int(Rnd * 13)'//←ランダムに数字を生成

    If cardArray2(n1)(n2) = True Then
        cardArray2(n1)(n2) = False
        myHandN(j) = cardArray(n1)(n2)
        myHandS(j) = suitArray(n1)
        j = j + 1
    End If
Loop

 

これで、5つの数字の配列はmyHandNに格納され、5つの絵柄の配列はmyHandSに格納されます。

数字をソートして並び替える

配列をソートさせるにはソートアルゴリズムを使えばよいのですが、アルゴリズムを一切勉強していない私はその方法を知らないので、ここは先人の知恵を借りました。なんと幸いにもクイックソートVBAで実装しているブログがありましたので、ここではそれをまるごとコピペして使わせてもらっています。ちなみに以下のブログです。

vbabeginner.net

ソート後の処理

ソート済みの手札の数字の配列ができたら、その配列と絵柄の配列2つを引数に、今回私が考えたポーカーの役を判定する関数「checkPokerHands」関数に渡します。先にソースコードを記載しておきます。

渡された引数のarNが5つの数字の配列であり、arSが絵柄の配列です。関数の戻り値は数字にしています(ロイヤルフラッシュが出たら7、ストレートフラッシュがでたら5など)。

Function checkPokerHands(ByVal arN As Variant, ByVal arS As Variant) As Integer
Dim num As Integer
Dim a As Integer, b As Integer, c As Integer, d As Integer

a = arN(4) - arN(3)
b = arN(3) - arN(2)
c = arN(2) - arN(1)
d = arN(1) - arN(0)

If arS(0) = arS(1) And arS(1) = arS(2) And arS(2) = arS(3) And arS(3) = arS(4) Then
    If arN(0) = 1 And arN(1) = 10 And arN(2) = 11 And arN(3) = 12 And arN(4) = 13 Then
        num = 7 '//ロイヤルフラッシュ
    ElseIf a = 1 And b = 1 And c = 1 And d = 1 Then
        num = 6 ' //ストレートフラッシュ
    Else
        num = 3 '//フラッシュ
    End If
Else
    If a = 1 And b = 1 And c = 1 And d = 1 Then
        num = 2 '//ストレート
    ElseIf arN(0) = 1 And arN(1) = 10 And arN(2) = 11 And arN(3) = 12 And arN(4) = 13 Then
        num = 2 '//ロイヤルストレート
    Else
        '//以下4カード、フルハウス、3カード、2ペアを判定
        '//(手札の中で同じ数字の組み合わせが見つかった回数で上記を判定)
        For maxNum = 3 To 0 Step -1
        i = 3 - maxNum
            For j = 1 To 1 + maxNum
                If arN(i) = arN(i + j) Then
                    cnt = cnt + 1
                End If
            Next j
        Next maxNum
    
        Select Case cnt
        Case 6
            num = 5 '//4カード
        Case 4
            num = 4 '//フルハウス
        Case 3
            num = 1 '//3カード
        Case 2
            num = 0 '//2ペア
        Case Else
            num = -1 '//1ペアもしくはブタ
        End Select
    End If
End If
    
checkPokerHands = num

End Function

まずはフラッシュかどうかを判定する

判定方法を解説します。まず上記では、絵柄の配列を使って、If文でフラッシュが成立するか否かを最初に判定しています。その後、数字が10,11,12,13,1だったらロイヤルフラッシュになります。もし手札の数字の1枚めと2枚め、2枚めと3枚目・・・というふうに隣同士の差を調べ、すべて1だったらストレートフラッシュ、それ以外ならただのフラッシュという判定を行っています。

フラッシュ以外を判定する

次にフラッシュ以外だった場合の処理です。まず先にストレートが成り立つかを判定します。これは先述の通り、手札内の各札の差が1ずつ並んでいるか、もしくは10,11,12,13,1(ロイヤルストレート)になればOKなので判定は簡単です。

もし上記が成り立たなかった場合、4カードかフルハウスか、3カードか2カードか、1ペアかブタを判定します。ここも私が思いついたのは、

「5枚の手札のうち2枚のカードが同じ数字になる数を数えて判断する」という方法です。その数を数えている部分が以下です。

For maxNum = 3 To 0 Step -1
i = 3 - maxNum
    For j = 1 To 1 + maxNum
        If arN(i) = arN(i + j) Then
            cnt = cnt + 1
        End If
    Next j
Next maxNum

例えば、1が4つそろった4カードとして

カードA:1

カードB:1

カードC:1

カードD:1

カードE:2

という手札があるとします。

このとき、カードA=カードB、カードA=カードC、カードA=カードD、カードB=カードC、カードC=カードD、というように同じ数字のペアが5つあるので、4カードの場合は「5」となります。

同じように、フルハウスは4、3カードは3、2カードは2、1ペアが1、ブタが0というように、偶然にもきれいに分かれるので、とても判定が楽です。ちなみに今回のポーカーのプログラムでは1ペアは役成立にみなしていないので、ブタと同じ扱いにしています。こうして役が判定されたらそれに応じて戻り値を設定します。

私が作ったポーカーのプログラムでは、戻り値を数字で欲しかったので、上記のサンプルもそうなっています。

最後に

以上、結構シンプルですね。最初「難しいんだろうなぁ・・」という先入観があったので二の足を踏んでいたのですが、案外すぐに作れました。まあクイックソートの部分は他の人のコードをそのまま作ったので、それを自分で書こうとしたらもっと時間がかかったかもしれません。肝心のExcelポーカーの方は、また別途ご紹介したいと思います。

JavaScriptで連想配列の中に連想配列を入れ子で入れる方法

JavaScriptを勉強しているとき、多次元配列を作る必要があり、いろいろと動作の実験をしてみました。ここでは自分用のメモとして以下のサンプルを作りました。連想配列を3つ重ねた3次元の配列です。

function test(){
  myArray = new Array();
  myArray =
    {ひらがな:
             {あ行:{a:"あ",i:"い",u:"う",e:"え",o:"お"},
              か行:{a:"か",i:"き",u:"く",e:"け",o:"こ"}
    },カタカナ:
             {ア行:{a:"ア",i:"イ",u:"ウ",e:"エ",o:"オ"},
              カ行:{a:"カ",i:"キ",u:"ク",e:"ケ",o:"コ"}
    }
};
 //配列の要素の呼び出し方は以下どちらでもよいようです。
  alert(myArray["ひらがな"]["あ行"]["e"]);
       // ==> "え"が出力される
  alert(myArray.カタカナ.カ行.o);
       // ==> "コ"が出力される

  /*ちなみに、配列の要素を変数を用いて呼び出したい場合*/
  var str1 = "ひらがな";
  var str2 = "か行";
  var str3 = "e";

  alert(myArray[str1][str2][str3]);
       //==> "け"が出力される
  alert(myArray.str1.str2.str3);
      // ==>この呼び出し方はできませんでした
}

調べていて、連想配列の要素を変数を用いて呼び出すやり方に謎を感じました。たとえば、以下の通常の配列の場合


array1 = ["あ","い","う","え","お"]


要素を取り出すときはarray1[0]のようにでくくって記述します。一方で、以下のように連想配列の場合


array2 = {a:"あ",i:"い",u:"う",e:"え",o:"お"}


要素を取り出すときは、array2.aのようにドットで記述しますし、通常の配列のようにarray2["a"]のような記述でも大丈夫です。


しかし!変数を使うときは以下のように、での記述しかダメ(?)みたいです。


var str1 = a;

array2 = {a:"あ",i:"い",u:"う",e:"え",o:"お"};

alert(array2[str1]);

//==>"あ"が出力される


素人の感覚からしたら、array2.str1って記述するのかなーと思いましたが違うのですね。不思議。ちなみに、自分のコーディングが間違ってるのか、多次元配列にするとき、通常の配列と連想配列の混在ってできないのだろうか・・動作しない・・

2次元配列を初期化する方法のメモ(VBAとJavaScript)

普段、Excel VBAJavaScriptを趣味で使うことがあるのですが、要素が空の2次元配列を作っておく(=2次元配列を初期化する)ケースに何件か遭遇したので、今後のためにメモしておきます。

JavaScriptで要素が空の2次元配列を作る

おそらく以下でOKのはずです。要素数が10×10の2次元配列arrができるはず。

var x, y, xMax, yMax;
yMax = 10;
xMax = 10;
var arr = new Array(yMax);
for(y = 0; y < yMax; y++) {
arr[y] = new Array(xMax);
   for(x = 0; x < xMax; x++) {
     arr[y][x] = "";
   }
}

Excel VBAで要素が空の2次元配列を作る

VBAを普通の使い方をしていると、2次元配列を作ることは非常にレアだと思いますが、私みたいにへんてこなツールを作っていると使うシーンがまれにあります。

以下、同様に10×10の空の要素が入っている2次元配列arができるはず。

Dim i As Integer, x As Integer, y As Integer, c As Integer
Dim ar() As Variant
x = 10
y = 10
ReDim ar(x) As Variant
For i = 0 To x - 1
    Dim a As Variant
    a = Array("")
    b = ""
    c = 0
    Do Until c > y
       ReDim Preserve a(UBound(a) + 1)
       a(UBound(a)) = b
       c = c + 1
    Loop
    ar(i) = a
Next i

VBAはそもそも配列に関する機能が貧弱なので、かなり面倒くさいですね・・JavaScriptはなんて簡単なことか(それが普通)

Excel VBAでユーザーフォーム上にマインスイーパを作る方法

 

f:id:tdyu5021:20190515020759p:plain

長年Windowsに搭載されてきたおなじみのゲーム「マインスイーパ」。VBAを使ってこれをExcelワークシート上で再現している情報はネットにいくつかありましたが、ユーザーフォームでやっている人は少なかったので、今回やってみました。その方法を紹介しようと思います。

マインスイーパの要件と気をつけるところ

ルールは説明するまでもないと思いますので、ここでは特に触れません。簡単な条件ですが、以下です。マスの数を可変にするのは難しいので今回は決め打ちで9マス×9マス、地雷は10個で固定。

  • マスは9マス×9マス
  • 地雷の数は10個
  • 右クリックで旗を立てる機能はあり

作る上で一番難しいかったのは「地雷がなく、かつ数字でもないマスを開いたらそのマスの周りの全方向を調べて数字があるマスまで全部開く」という部分ですね。これはあとで解説します。 

コードの解説

xlsmファイルはこちらにアップしておりソースコードは記事の最後に書きますが、ポイントとなる部分だけ解説します。

マスの作成

当たり前ですが、まず以下のようにラベルオブジェクトでマスを作っていきます。

f:id:tdyu5021:20190515025145p:plain

今回はラベルの名前は左上から右方向にL1、L2、L3・・・L81としました。フォームのオブジェクト名は「form」、クラスモジュールの名前は「class1」。それ前提で解説を進めていきます。

マスに地雷をセットする

UserForm_Initializeでゲームを始めるのに必要な処理を行います。その1つがラベルへの地雷のセットです。それを行っているのがソースコード中のmineSetプロシージャです。

地雷の場所は変数上で管理します。1から81までランダムな数字を生成してそれを地雷番号として、同じく1から81まで要素をもつ配列変数status()中の番号に対して、もし地雷番号と合致すれば数字の2を格納する処理を行います。

マスに数字をセットする

マインスイーパではマス上に、そのマスの周りに地雷がいくつあるかを示す数字が書いてあります。この情報を格納します。これもマスであるラベルオブジェクトには直接記入しません。1から81まで要素を持つlNum()という配列変数の要素それぞれに、セルに記載する地雷数の数字を格納していきます。

合わせて、先程の配列変数status()にも、地雷数を記入するラベルの番号には数字の1を格納していきます。

この配列変数status()は81個のラベルが、「地雷のラベルか」「数字のラベルか」「何も記入のないラベルか」を判断するためのものです。

どうやってマスの周りの地雷数を数えているか

次に、81個のマスに対してループをかけて地雷数を記入するわけですが、マスをi番とするとその周りの8方向(i - 10, i - 9, i - 8, i - 1, i + 1, i + 8, i + 9, i + 10)のstatusを調べて、それが数字2だったら地雷がある、という判定を行います。

ただ、当然のことながらすべてのマスに対して「8方向を調べる」というロジックは使えません。例えば左上の端のマスは「左、左下、下」の3方向を調べるだけです。

あとから知ったのですが、これを回避するために、端のマスの外にも実際には使わないダミーのマスを設けるという手法があったのですが、このときはそれを知らなかったので、違う方法で行いました。

それが、例えばマスが四隅(マス1、マス9、マス72、マス81)のときは周り3方向を調べ、上端のマスのときは上を除く5方向を調べ・・・というように、探索するマスの方向をselect caseで条件に応じて変えるという地味な手段です。

クリックイベント処理を共通化する

今回は81個のマスがあり、クリックしたら開くというどれも同じ処理を行います。これをどう実装すればよいでしょうか。単純な方法として、以下の画像のようにラベルのクリックイベントを81個分書くという選択肢もあります。

f:id:tdyu5021:20190515025610p:plain

ですが、同じことを何度も書くのでコードとしてはかっこ悪いですね。実はこの煩雑さを解消する方法があるのです。

クラスモジュールとWithEventsというキーワードを使うことで、複数のオブジェクトのイベントを1つのイベントプロシージャに集約できるのです。解説は多く出回っていますが、私が参考にしたのは以下の記事です。

ateitexe.com

私もいまいち掴みきれていないのですが、私が作ったソースコードを例に、イベント処理を一括化する方法というか理屈を以下に見てみましょう(説明が適切かは不明)

(1)WithEventsキーワードでラベルオブジェクト型の変数myLblを宣言する。

ソースコード内にあるlblSetというプロシージャで、その変数myLblにラベルオブジェクトのインスタンスを突っ込んでいくための処理を書きます(クラスモジュール内の以下の処理)

Public Sub lblSet(ByVal obj As MSForms.Label)
    Set myLbl = obj
End Sub

(2)81個分のインスタンスを作る

当然のことながら実際にラベル81個分のインスタンスを変数に入れるには、まずインスタンス作って上記のlblSetを実行することが必要になります。これは、UserForm_Initialize()のプロシージャに書いてあった以下の部分です。

For i = 1 To 81
    lblArray(i).lblSet Controls("L" & i)
Next i

※上記3行以外にごちゃごちゃ他の記述もありますが、シンプルにするため上記3行だけあえて抜き出しています。

(3)クラスの宣言をしておく

もちろん、その前にクラスを宣言する必要があるので、ユーザーフォームでも標準モジュールどちらでも良いと思いますが、以下を宣言しておきます。

Public lblArray(1 To 81) As New class1

こうすることで、81個のラベルオブジェクトは、すべてmyLblというオブジェクトになり、クリックとかマウスオーバーとか、ラベルオブジェクトに対してVBAで用意されているイベント処理が適用されるのです。ソースコードでは以下の部分です。

Private Sub myLbl_Click()
    Call openLbl(myLbl)
End Sub

私もうまく説明できないので最初に示したリンクを参照されると良いと思います。

マスをクリックしたときの処理

さて、このプログラムで一番厄介なところです。マスをクリックしたらそのマスを開き、もし地雷だったらゲームオーバー、数字だったらマスに数字を記入、もし空欄だったら数字を開くまで隣のマスを探索し続けます。

f:id:tdyu5021:20190516011801p:plain

この中で一番難しいのは、「クリックしたら空欄である限りその隣も開き続ける」という処理です。これは、openLblというプロシージャを一定の条件(=数字が書いてあるマスを開くこと、また開いたマスが端のマスであること)まで再帰処理させることで実現します。

加えて、全方位に調べるということなので、openLblプロシージャ内に、左上、上、右上、左、右、左下、下、右下の8種類のCall OpenLbl()があり、その引数にはそれぞれが向かう方向のラベルオブジェクトを取ります。

一例として、今クリックしたラベルの番号を仮に変数nとおくと、例えば左上への探索だったらCall openLbl(form.Controls("L" & n- 10))という感じですね。

マスを開き続ける再帰処理をどう止めるか

例えばマスをクリックしてどんどん開き続けたとき、もし左上方向への再帰処理であれば、上端のマス(=L1、L2、L3、L4、L5、L6、L7、L8)を開かれたら処理を止める必要があります。もちろん、8方向それぞれに対して止めるトリガーとなる終端のマスは異なります。そこで、私はarr()という配列変数を8個作り、それぞれの方向への再帰処理を止めるマス番号を格納しました。

要するに、左上方向への再帰処理は、arr(0)内のいずれかのマスに来たら処理終了、上方向への再帰処理はarr(1)内のいずれかのマスに来たら終了、というやり方です。

右クリックで旗を置く

マインスイーパには右クリックで目印の旗を置く機能があります。旗の絵を置くのが面倒なので、?のマークを置くことにしました。最初このマインスイーパを作ったとき、VBAでフォーム上で右クリックイベントができることを知らなかったので、この機能はつけていませんでしたが、調べてみたら方法があるらしいので最近実装しました。

それがソースコード内でいう、myLbl_MouseDownのイベントプロシージャです。ほぼコピペベースでやったので詳しいことはわかりませんが、どうやらButtonという引数にクリックされたボタンが渡されるらしいです。ちなみに右クリックするとButtonには2の数字が渡されます。それ以外の引数についてはよくわかりません。

 そんな感じでなんとかでき上がりました。以下プレイ動画です(私は全然うまくないので、結構時間かかっています・・・)

f:id:tdyu5021:20190516014818g:plain

ソースコード

以下、ソースコードです。

'-----------------------------------------------------------------------'
'                            標準モジュール
'-----------------------------------------------------------------------'

Public lightColor As Variant
Public darkColor As Variant
Public blackColor As Variant
Public status(1 To 81) As Integer '//ラベルの状態:0=数字なし、1=数字あり、2=地雷あり
Public LNum(1 To 81) As Integer '//各81枚のラベルに記載する数字を格納
Public lblCount As Integer
Public lblArray(1 To 81) As New class1
Public gameOverFlg As Boolean
Sub startGame()
    form.Show
End Sub

'-----------------------------------------------------------------------'
'                            ユーザーフォーム
'-----------------------------------------------------------------------'

Private Sub UserForm_Initialize()
Dim i As Integer, j As Integer
gameOverFlg = False
lightColor = RGB(200, 200, 200)
darkColor = RGB(160, 160, 160)
blackColor = RGB(0, 0, 0)
lblCount = 0

For i = 1 To 81
    With form.Controls("L" & i)
        .ForeColor = darkColor
        .BackColor = darkColor
        .Caption = ""
    End With
    status(i) = 0
    LNum(i) = 0
    lblArray(i).lblSet Controls("L" & i)
Next i

Call mineSet '//爆弾をセットする
Call numberSet '//数字をセットする
    
End Sub
Private Sub CommandButton1_Click()
    UserForm_Initialize
End Sub
Private Sub mineSet()
'//ラベルに地雷をセット
Dim cnt As Integer
Dim num As Long
cnt = 0

Randomize

Do

Do
    num = Int(Rnd * 81) + 1
    If status(num) <> 2 Then
        status(num) = 2
        cnt = cnt + 1
        If cnt = 10 Then Exit Sub
        Exit Do
    End If
Loop

Loop

End Sub
Sub numberSet()
Dim i As Integer, j As Integer
Dim arr As Variant
Dim arrLength As Integer
Dim mineCnt As Integer

For i = 1 To 81
mineCnt = 0
    Select Case i
    Case 1, 9, 73, 81
        Select Case i
            Case 1
                arr = Array(2, 10, 11)
            Case 9
                arr = Array(8, 17, 18)
            Case 73
                arr = Array(64, 65, 74)
            Case 81
                arr = Array(71, 72, 80)
        End Select
    Case 2 To 8
        arr = Array(i - 1, i + 1, i + 8, i + 9, i + 10)
    Case 74 To 80
        arr = Array(i - 10, i - 9, i - 8, i - 1, i + 1)
    Case 10, 19, 28, 37, 46, 55, 64
        arr = Array(i - 9, i - 8, i + 1, i + 9, i + 10)
    Case 18, 27, 36, 45, 54, 63, 72
        arr = Array(i - 10, i - 9, i - 1, i + 8, i + 9)
    Case Else
        arr = Array(i - 10, i - 9, i - 8, i - 1, i + 1, i + 8, i + 9, i + 10)
    End Select
    arrLength = UBound(arr)
    
    '//1マスごとに周囲にいくつ地雷があるかを数える
    For j = 0 To arrLength
        If status(arr(j)) = 2 Then
            mineCnt = mineCnt + 1
        End If
    Next j
    
    '//地雷の数が1以上ならマスに記入
    If mineCnt > 0 And status(i) <> 2 Then
        status(i) = 1
        LNum(i) = mineCnt
    End If
Next i


End Sub

'-----------------------------------------------------------------------'
'                            クラスモジュール
'-----------------------------------------------------------------------'

Private WithEvents myLbl As MSForms.Label
Public Sub lblSet(ByVal obj As MSForms.Label)
    Set myLbl = obj
End Sub
Private Sub myLbl_Click()
    Call openLbl(myLbl)
End Sub
Private Sub myLbl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    If Not myLbl.BackColor = darkColor Then Exit Sub
    If Button = 2 Then
        If myLbl.Caption = "" Then
            myLbl.Caption = "?"
        Else
            myLbl.Caption = ""
        End If
        myLbl.ForeColor = blackColor
    End If
End Sub
Private Sub openLbl(clickedLbl As MSForms.Label)
Dim x As Integer
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, o As Integer, p As Integer, q As Integer
Dim lblNum As Integer
Dim arr(7) As Variant
Dim stopFlg(7) As Boolean
Dim opendLblNum As Integer
'//クリックしたラベルの番号だけを取得
lblNum = Mid(clickedLbl.Name, 2, Len(clickedLbl.Name) - 1)

'//ラベルを開く再帰処理を止めるフラグを初期化
For x = 0 To 7
    stopFlg(x) = False
Next x
'//ラベルを開く再帰処理を止めるための条件
arr(0) = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 19, 28, 37, 46, 55, 64, 73) '左上
arr(1) = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)  '上
arr(2) = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 18, 27, 36, 45, 54, 63, 72, 81) '右上
arr(3) = Array(1, 10, 19, 28, 37, 46, 55, 64, 73) '左
arr(4) = Array(9, 18, 27, 36, 45, 54, 63, 72, 81)  '右
arr(5) = Array(1, 10, 19, 28, 37, 46, 55, 64, 73, 74, 75, 76, 77, 78, 79, 80, 81) '左下
arr(6) = Array(73, 74, 75, 76, 77, 78, 79, 80, 81)  '下
arr(7) = Array(9, 18, 27, 36, 45, 54, 63, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81)  '右下

If clickedLbl.BackColor = lightColor Or gameOverFlg = True Then
    '//すでにラベルが開いているかゲームオーバーになってる場合は何もしない
    Exit Sub
Else
    '//ラベルを開く(=色を変える)
    clickedLbl.BackColor = lightColor
    If LNum(lblNum) <> 0 Then clickedLbl.Caption = LNum(lblNum)
    If clickedLbl.Caption = "?" Then clickedLbl.Caption = ""
    Call checkGameOver(lblNum)
    openedLblNum = countLbl
End If
    
'//ラベルの数字によって文字の色を変える(本当は8まで必要だが・・・)
Select Case clickedLbl.Caption
    Case 1
        clickedLbl.ForeColor = RGB(11, 49, 143)
    Case 2
        clickedLbl.ForeColor = RGB(230, 0, 18)
    Case 3
        clickedLbl.ForeColor = RGB(0, 154, 62)
    Case 4
        clickedLbl.ForeColor = RGB(4, 29, 90)
    Case 5
        clickedLbl.ForeColor = RGB(153, 0, 0)
End Select


'/* 以下、ラベルをクリックしたときそれが空欄である
'/ (statusが0)限り隣のラベルを開き続ける再帰処理 */
If status(lblNum) = 0 Then
    '//左上
    For i = 0 To UBound(arr(0))
        If lblNum = arr(0)(i) Then
            stopFlg(0) = True
            Exit For
        End If
    Next i
    If stopFlg(0) = False Then Call openLbl(form.Controls("L" & lblNum - 10))
    
    '//上
    For j = 0 To UBound(arr(1))
        If lblNum = arr(1)(j) Then
            stopFlg(1) = True
            Exit For
        End If
    Next j
    If stopFlg(1) = False Then Call openLbl(form.Controls("L" & lblNum - 9))
    
    '//右上
    For k = 0 To UBound(arr(2))
        If lblNum = arr(2)(k) Then
            stopFlg(2) = True
            Exit For
        End If
    Next k
    If stopFlg(2) = False Then Call openLbl(form.Controls("L" & lblNum - 8))
    
    '//左
    For l = 0 To UBound(arr(3))
        If lblNum = arr(3)(l) Then
            stopFlg(3) = True
            Exit For
        End If
    Next l
    If stopFlg(3) = False Then Call openLbl(form.Controls("L" & lblNum - 1))
    
    '//右
    For m = 0 To UBound(arr(4))
        If lblNum = arr(4)(m) Then
            stopFlg(4) = True
            Exit For
        End If
    Next m
    If stopFlg(4) = False Then Call openLbl(form.Controls("L" & lblNum + 1))
   
    '//左下
    For o = 0 To UBound(arr(5))
        If lblNum = arr(5)(o) Then
            stopFlg(5) = True
            Exit For
        End If
    Next o
    If stopFlg(5) = False Then Call openLbl(form.Controls("L" & lblNum + 8))
    
    '//下
    For p = 0 To UBound(arr(6))
        If lblNum = arr(6)(p) Then
            stopFlg(6) = True
            Exit For
        End If
    Next p
    If stopFlg(6) = False Then Call openLbl(form.Controls("L" & lblNum + 9))
    
    '//右下
    For q = 0 To UBound(arr(7))
        If lblNum = arr(7)(q) Then
            stopFlg(7) = True
            Exit For
        End If
    Next q
    If stopFlg(7) = False Then Call openLbl(form.Controls("L" & lblNum + 10))
End If

If openedLblNum = 71 Then
    MsgBox "GAME CLEAR!!"
    gameOverFlg = True
End If
End Sub
Private Sub checkGameOver(ByVal n As Integer)
'地雷を開いてしまったときの挙動
Dim i As Integer
If status(n) = 2 Then gameOverFlg = True

If gameOverFlg = True Then
For i = 1 To 81
    With form.Controls("L" & i)
        .ForeColor = blackColor
        If status(i) = 2 Then
            .Caption = "*"
            .BackColor = RGB(255, 0, 0)
        Else
            If status(i) = 1 Then
                .Caption = LNum(i)
            End If
            .BackColor = lightColor
        End If
    End With
Next i
End If

End Sub
Function countLbl() As Integer
    lblCount = lblCount + 1
    countLbl = lblCount
End Function

VBA→JavaScriptと入っていった私が感じたこと

プログラミング言語に触ったきっかけ

私が多少でもコードを書いて何らかのプログラムを作ったことがあるのは、VBAJavaScript(加えてGoogle Apps Script)だけです。

以前、単純作業が多い古臭い会社に勤めていたもので、そこでの業務効率化のためにVBAを始めていったらものすごくハマってしまい、その後プログラミングそのものに興味を持ち始めました。

業務で必要だったわけではありませんが、その後趣味としてオンラインで学習できるツールでJavaScriptの文法を勉強しました。JavaScriptをやろうと思ったきっかけはもう覚えていませんが、とりあえずなんでもいいからプログラミング言語というものを触ってみたいという好奇心と、ブラウザとメモ帳さえあればできるというわかりやすさだったでしょう。

このときが確か2013年か2014年。JavaScriptだけ覚えても意味がないのでHTMLとCSSの基礎中の基礎も勉強しました。そのとき使ったのがかの有名なProgateです。今や有名になりましたが、まだこのときはサービス最初期の頃でした。

JavaScriptの方は、Jeek CodeStudyという無料のオンライン学習サービスで勉強しました。おそらくこれは当時使った形では、現在もう残っていないかと思われます。

最初に作ったものはもはや覚えていませんが、じゃんけんのプログラム(グーチョキパーを2つ表示させ、その組み合わせで勝ち、負け、あいこの文字をブラウザ上に表示させる程度のもの。もちろんCSSなどは使っていない)を書いた記憶があります。おそらく少し勉強すれば小学生でも書けるようなものです。

そんなこんなで触り始めたのはもうだいぶ前ですが、継続的にプログラミングをしていたわけでなく途中一切やっていない時期も多かったので、2019年現在、私は対して上達してません。

JavaScriptに触って感じたこと

本題です。VBAの簡易なものと、それなりにしっかりしている言語であるJavaScriptの2つを触ってみて、当然ですが結構違いがあるなと思いました。JavaScriptの数%も理解していませんが、クソ素人目からみて私が感じる印象は以下です。

JavaScriptのforループの書き方に感動する

今でも毎回思うのですが、VBAのforループを書くとき

for i = 1 to 10

next i

のようにカウンタの変数が必要(←他の言語でもそうですが)になるわけですが、そのカウンタ変数をforループのために、forループの外に記入するのがどうも気になります。

そんな中

for(var i = 0; i < 10;i++){

}

カウンタ変数の宣言をforループの中に入れられる書き方には気持ちよさを感じました。

{}のかっこで挟めばよいのが楽

これもしょうもないことなのですが、VBAだとIfをEnd Ifで閉じたり、For LoopをNextで閉じたりするのもなんか好きではありません。無駄に行数とっているのと、あと結構閉じ忘れるのですよね。

配列に関するメソッドの豊富さに感動

JavaScriptをやっていてVBAのような言語と決定的に違うと思ったのが、配列の操作ですね。それはJavaScriptが充実しているのでなく、それがプログラミング言語の当たり前であって、VBAがなさすぎる。

ただ、それはVBAへの文句ではありません。VBAの場合はまともな使い方をしていれば配列の操作をあまり必要としないんですよね。セルに書き出した内容に対して操作を加えることが多いので、配列の変数上でごにょごにょしたりするケースは少ないように思います。私のようにVBAを使って変なプログラムや変なツールをつかっていると「配列のあの操作ができれば・・!」なんてしょっちゅう思うのですが、それはむしろ異端です。

VBAJavaScriptから入ったことを振り返って

たまに、ネット界隈でプログラミング言語は何から始めたほうが良いかという話題が上がります。これはどの方も「自分がやりたい目的次第」と答えるでしょう。ただ、その中でたまにJavaScriptを推す人がいて、その理由は環境構築が一切不要だからです。ブラウザとメモ帳があればプログラムを書いて動かせるというのは本当にすごいと思います。

VBAもエクセルだけあればよいという意味で同様ですが、VBAの言語の目的はエクセル操作に関することが中心なので、業務でエクセルを頻繁に触っている人なら興味を持つでしょうが、そうでない人にはあまり響かないでしょう。

私自身は他のプログラミング言語を触ったことないので何から始めればよいかというのはさっぱりわかりませんが、VBAJavaScriptも触っておいておかったなあと思います。コンパイルもいりませんので、自分の書いたコードすぐに何らかの形で結果としてすぐ動くというのは、それだけでとても嬉しいものでした。

程度はまったく大したものではありませんが、プログラミングはやっていて楽しいです。今からでもなりたいなぁといつも思っているくらいです。ただ、自分は書くのにも時間がかかり理解も遅くあまり向いてないと思うのでなれないでしょうけど。

でも趣味として今後ものんびりとちょっとしたプログラムを書いていこうかなと思います。(本職があまりにも多忙で趣味の時間が取れないというのが悩み)

Excelで作られた迷路を自動で解いて正答ルートを描画するマクロ

f:id:tdyu5021:20190507015403p:plain

これは前回の以下の記事の続きです。

tdyu.hatenablog.jp

Excelのセルと罫で作られた迷路を自動で解くというプログラムをVBAで作ってみたところ、意外と反響が大きかったので、ここではどういう仕組みでそれを実現したのかを解説してみます。

Excel迷路を自動で解くとはどういうこと?

まず、本記事を最初に見られた方は「Excelで作られた迷路を自動で解く」については、以下のTwitterの動画をご覧ください。

この迷路は一番オーソドックスな迷路であり、正解ルートが1つだけしか存在しないものです。迷路によっては、途中で道と道がつながり合い、複数の正解ルートがあるものもありますが、今回はそのようなものではありません。

迷路の正解ルートを自動で描画するアルゴリズム

上記のマクロをTwitterで投稿したところ、迷路の生成も解答もどんな仕組みなのか、どんなアルゴリズムなのかを気にされる方が多くいらっしゃいました。

ただ、私はアルゴリズムありきで作ったわけでもなく、そもそもアルゴリズムも詳しくありません。なので結局のところアルゴリズムの名前はわかりませんが、ゴールにたどり着くロジックは以下の画面の通りです。

f:id:tdyu5021:20190507020144p:plain

おわかりの通り、仕組みだけなら一切難しいことはしていません。道が分かれていたらまず進んでみて、行き止まりがあったら分岐まで戻って…これを繰り返せばいずれゴールにたどり着きます。少し調べたところ、このアルゴリズムは「深さ優先探索」というものかもしれません。

とはいえ、プログラマーではない私がこれをExcel VBAで作るのには本当に苦労し、正直めちゃくちゃ時間がかかりました。プログラミングやアルゴリズムがわかる方ならその何十分の1の時間で終わったでしょう。

単に迷路を解く(=ゴールの座標に到達する)ことはおそらく難しくはありませんが、やっかいだったのが今回作ったマクロの要件のもう1つ「正解のルートだけを色付けする」。これが本当に苦労しました。これは次の項で見ていきます。

正解のルートだけを色付けする方法

正解のルートに到達する方法を考える前に、まずはこのマクロでもっともやっかいな「正解のルートだけを色付けする」ロジックを考えてみましょう。

道を通るたびにInteriorプロパティでセルに色を付けて消してを繰り返していては、当然のごとく処理時間が遅くなるので、正解ルートの座標を1マスずつ配列にいれ、最後にまとめて色付けします。問題なのは途中の通路をどうやって配列にいれるかです。

分岐から分岐までの通路を複数の配列で管理する

迷路では、分岐してからの道がゴールに到達するかを探索しますが、もし間違った道に進めば行き止まりに達します。そのため、ある地点からは間違ったとしても、それ以前の正解だと確定しているルートを記憶しておく必要があります。それを実現するために私が考えたのは、例えば分岐Aから分岐Bまで、分岐Bから分岐Cまでなど、分岐間の通路の座標をすべて異なる配列変数に格納するという方法です。まず下記の画像を見てください。

f:id:tdyu5021:20190507020737p:plain

分岐から分岐まで違う数字を記入した図です。上記の画像でいう通路0の3つのマスの座標をrouteArr(0)に入れておき、分岐してからの通路1の4つのマスの座標をRouteArr(1)に入れていくという方法です。

なお座標は、行をy、列をxとし、これをyyxxの文字列の形で上記配列に格納しています。セルオブジェクトの形で配列に入れられれば最後の描画で非常に楽だったのですが、VBAのArrayはオブジェクトをいれることができないための苦肉の策です。

よって上記の画像の迷路を例に取ると、通路履歴の配列には:

  • routeArr(0) = (0101,0102,0202) ←0の通路
  • routeArr(1) = (0203,0204,0205,0105) ←1の通路
  • routeArr(2) = (0106,0206,0306,0406,0407,0408,0308) ←2の通路

という要素が入っていることになります。

こうすることで、例えば仮に最初の分岐から左に進んでrouteArr(1)に0201,0301,0302が入ったとします。もしその先が行き止まりになり、そこに入れた配列の要素をすべて消去し、最初の分岐を右に進んでrouteArr(1)を0203,0204,0205と入れ直したとしても、確定しているrouteArr(0)のルートは消されずに保たれる仕組みです。

なお、現在値を表すy、xについても、プログラム中では配列変数で管理しています。たとえば、上記画像の0の通路は、y(0)、x(0)、1の通路はy(0)、x(0)という具合です。

スタートからゴールまでの手順

それでは、ポイントをかいつまんでゴールにいくまでどのようなことをしているのかを紹介します。

現在地の周りの何方向に壁があるかを探索

まず、あるセル(座標)から、何方向に進めるかを検索します。後述のソースコードでは、getDirectionArrayという関数で求め、進める方向の数字をarr()という配列に格納しています。

ゴールに向かって進んでいく

上記の検索で、もし進める方向があれば、yまたはx座標を1つずらし、移動後の座標をrouteArr()に格納していきます。繰り返しになりますが、配列にいれるのは、最後の描画用に通路の履歴を残すためです。1方向しか進めない場合は、単純にその方向に座標を進め、そして再帰処理を行います。

もし分岐から2方向に進める場合は

この場合、進める方向の番号2つを配列のarr(0)、arr(1)に入れ、Forループでその2つの方向それぞれに再帰処理を行い進めていきます。その際に行っているのは、ループの2回目でその分岐からの座標の履歴の配列(=routeArr)を初期化することです。

上記Forループで分岐先1本目を進んで道を配列に格納しても、行き止まりに達したらその進んだ通路はもう不要になるからです。VBAでは配列要素を削除するメソッドがないので、とりあえず空の文字列要素100個を入れるということで初期化にしています。(100マスしかないので通路履歴のrouteArr(x)が100を超えることはありえないからです)

For xx = 0 To 100
   routeArr(nm)(xx) = ""
Next xx

もし3方向に分岐がある場合は

実を言うと、このマクロはまだここが欠陥です。迷路生成では3方向に分岐するものはできないと勝手に思っていたのですが、どうやらまれにできてしまうようで、その際はこの解答マクロは動きません・・・動くように修正はできると思いますが、そこまでできていません。これは余力があったらやります。

もし行き止まりになったら

現在値の座標の周りが全部壁でどこにも進めない場合の処理はどうでしょうか。この場合2パターン可能性があります。もう一度以下の画像を見てください。

f:id:tdyu5021:20190507020144p:plain

上記画像内の行き止まり1に達した場合、これは分岐3からのForループの1回目が行き止まりになったことを意味します。ですから通路の番号の変数を1つ下げ、分岐3の下の道を試行すればOKです(Forループの2回目)。

しかし、行き止まり2、行き止まり3も行き終わってしまったら今度は分岐3よりもっと前の分岐2まで戻る必要があります。

上記画像の場合、戻る先はたまたま2つ前でしたが、どの分岐点まで戻るかは分岐の深さによって迷路によって異なります。そのためどの分岐まで戻れるかを調べる必要があるのです。

これを調べる方法としては、本当はもっとよいやり方があるかもしれませんが、このマクロでは、新しいものから各分岐のセルの四方を調べ、そこに通過済みのフラグや壁がない方向が見つかったらそこに戻るという無難な処理で対処しています。それを調べる関数がcheckAround関数です。

ちなみに、過去の分岐に戻るのは、分岐2回目も行き止まりだった場合(=Forループ2回目)なので、Forループ2回目に入ったことを示すフラグ(backFlg)と、行き止まりに達した際に過去の分岐に戻るフラグ(stopFlg)を立てています。

ゴールしたら

この迷路では決め打ちで10マス×10マスの迷路で、ゴールも右下と決めているので、y()座標、x()座標がどちらも10になったら終了です。最後にrouteArr(0)~routeArr(5)に格納した配列要素をループにかけて該当セルを色付けしていきます。routeArrにはyyxxの形式で正解ルートの座標が1マスずつ入っていることを示すために、以下のGIF動画をご覧ください。正解ルートの色付けのほか、routeArr()の中身を書き出しています。

f:id:tdyu5021:20190507022205g:plain

以上です。

ソースコード

以下ソースコードです。前回の記事で紹介した方法で迷路を作成したあと以下のコードを標準モジュールにコピペすればそのまま動くと思います。途中触れたように、3つに分かれる分岐がある迷路は動かない欠陥品です…何卒ご了承ください。

Dim mazeArea As Range
Dim y(100) As Integer, x(100) As Integer
Dim nm As Integer
Dim flgArr(11) As Variant
Dim routeArr(100) As Variant
Dim routeCounter As Integer
Dim stopFlg(100) As Boolean
Dim goalFlg As Boolean
Dim backFlg As Integer
Sub initializing02()
Dim prevDirecNum  As Integer
Dim h As Integer, i As Integer, j As Integer, cnt As Integer
Dim yy As String, xx As String

'//迷路の範囲を定義
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))

'//行き止まりに達したとき前々回の分岐まで戻るかどうかを判断するフラグ
'//(配列変数を動的に増やすのが面倒なのでとりあえず100個くらいつくっておく)
For h = 0 To 100
    stopFlg(100) = False
Next h

'//マスが埋まっているかいないかを1か0で判定するための配列
flgArr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
flgArr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
For i = 1 To 10
    flgArr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i

'//ゴールしたらオンにするフラグ
goalFlg = False

'//nmは分岐から分岐までの番号
'//routeCounterは分岐から分岐まで進んだ座標を格納するループカウンタ
nm = 0
routeCounter = 0

'//要素数100個の空の2次元配列を作っておく。ここに確定ルートの座標を格納していく
For j = 0 To 100
    Dim a As Variant
    a = Array("")
    b = ""
    cnt = 0
    Do Until cnt = 100
        ReDim Preserve a(UBound(a) + 1)
        a(UBound(a)) = b
        cnt = cnt + 1
    Loop
    routeArr(j) = a
Next j

'//座標の初期値
y(nm) = 1
x(nm) = 1
'//すでに通った座標にフラグオン
flgArr(y(nm))(x(nm)) = 1

Call writeNumber '//デバッグ用(迷路上のセルにnmを書き出す)

'//確定したルートの座標を格納。セルオブジェクトは配列に入れられないのでyx座標をyyxxの形で文字列で格納しておく */
    If y(nm) < 10 Then
        yy = "0" + "" + CStr(y(nm))
    Else
        yy = CStr(y(nm))
    End If
    If x(nm) < 10 Then
        xx = "0" + "" + CStr(x(nm))
    Else
        xx = CStr(x(nm))
    End If
    routeArr(nm)(routeCounter) = yy + "" + xx
    routeCounter = routeCounter + 1
'/* 確定ルートの配列化はここまで           */

'//次進むセルからみて、今自分がいる方向の番号(1:上、2:右、3:下、4:左)
prevDirecNum = 1

Call solveMaze(prevDirecNum)

End Sub
Sub solveMaze(prevDirecNum_ As Integer)
Dim ii As Integer
Dim wallNum As Integer
Dim prevDirecNum_2 As Integer
If goalFlg = True Then Exit Sub

'//ゴールの座標に来たら終了
If y(nm) = 10 And x(nm) = 10 Then
    Call drawRoute
    goalFlg = True
    Exit Sub
End If

'//壁がない方向を調べて配列に入れる
arr = getDirectionArray(prevDirecNum_)

'//壁がない方向の数を変数に入れる
If arr(0) = "" Then
    wallNum = 0
ElseIf arr(1) = "" Then
    wallNum = 1
Else
    wallNum = 2
End If

'//壁に接しない面が0箇所の場合(=行き止まりの場合)
If wallNum = 0 Then
    routeCounter = 0
    '//backFlgが0なら前の分岐に。1ならそれより前の分岐を調べて戻る
    If backFlg = 0 Then
        y(nm) = y(nm - 1)
        x(nm) = x(nm - 1)
    ElseIf backFlg = 1 Then
        If stopFlg(nm) = True Then
            newNm = checkAround(nm)
            nm = newNm + 1
            y(nm) = y(newNm)
            x(nm) = x(newNm)
        End If
    End If

'//壁に接しない面が1箇所(前回自分がいた方向は除いて)の場合
ElseIf wallNum = 1 Then
    '//次に進む方向を決定する&その移動先から見て自分がいた方向の番号を変数に
    Select Case arr(0)
        Case 1
            y(nm) = y(nm) - 1
            prevDirecNum_2 = 3 '//下
        Case 2
            x(nm) = x(nm) + 1
            prevDirecNum_2 = 4  '//左
        Case 3
            y(nm) = y(nm) + 1
            prevDirecNum_2 = 1  '//上
        Case 4
            x(nm) = x(nm) - 1
            prevDirecNum_2 = 2 '//右
    End Select

    '//すでに通った座標にフラグオン
    flgArr(y(nm))(x(nm)) = 1
    
    Call writeNumber '//デバッグ用(迷路上のセルにnmを書き出す)
    
    If y(nm) < 10 Then
        yy = "0" + "" + CStr(y(nm))
    Else
        yy = CStr(y(nm))
    End If
    If x(nm) < 10 Then
        xx = "0" + "" + CStr(x(nm))
    Else
        xx = CStr(x(nm))
    End If

    routeArr(nm)(routeCounter) = yy + "" + xx
    routeCounter = routeCounter + 1
    
    '//再帰
    Call solveMaze(prevDirecNum_2)

'//壁に接しない面が2箇所(前回自分がいた方向は除いて)の場合
ElseIf wallNum = 2 Then
    nm = nm + 1
    routeCounter = 0
    
    y(nm) = y(nm - 1)
    x(nm) = x(nm - 1)

For ii = 0 To 1
    '//ゴールしているなら終了
    If goalFlg = True Then Exit For
    
        For xx = 0 To 100
            routeArr(nm)(xx) = ""
        Next xx
    
    '//もし2つに分かれている道で2経路とも探索が終わったらフラグを立てる
    If ii = 1 Then
        backFlg = 1
        stopFlg(nm) = True
    Else
        backFlg = 0
    End If
      
    Select Case arr(ii)
        Case 1
            y(nm) = y(nm) - 1
            prevDirecNum_2 = 3
        Case 2
            x(nm) = x(nm) + 1
            prevDirecNum_2 = 4
        Case 3
            y(nm) = y(nm) + 1
            prevDirecNum_2 = 1
        Case 4
            x(nm) = x(nm) - 1
            prevDirecNum_2 = 2
    End Select

     '//すでに通った座標にフラグオン
    flgArr(y(nm))(x(nm)) = 1
    
    Call writeNumber '//デバッグ用(迷路上のセルにnmを書き出す)
    
    If y(nm) < 10 Then
        yy = "0" + "" + CStr(y(nm))
    Else
        yy = CStr(y(nm))
    End If
    If x(nm) < 10 Then
        xx = "0" + "" + CStr(x(nm))
    Else
        xx = CStr(x(nm))
    End If

    routeArr(nm)(routeCounter) = yy + "" + xx
    routeCounter = routeCounter + 1
    
    '//再帰
    Call solveMaze(prevDirecNum_2)
Next ii
    
End If

End Sub
Function getDirectionArray(n As Integer) As Variant
'/* 次に進める方向を配列に入れるための関数 */
Dim i As Integer
Dim direction As Variant
i = 0
direction = Array("", "", "", "")
With mazeArea
    If .Cells(y(nm), x(nm)).Borders(xlEdgeTop).LineStyle = xlNone Then
        If n <> 1 Then
            direction(i) = 1
        i = i + 1
        End If

    End If
    If .Cells(y(nm), x(nm)).Borders(xlEdgeRight).LineStyle = xlNone Then
        If n <> 2 Then
            direction(i) = 2
        i = i + 1
        End If
    End If
    If .Cells(y(nm), x(nm)).Borders(xlEdgeBottom).LineStyle = xlNone Then
        If n <> 3 Then
            direction(i) = 3
        i = i + 1
        End If
    End If
    If .Cells(y(nm), x(nm)).Borders(xlEdgeLeft).LineStyle = xlNone Then
        If n <> 4 Then
            direction(i) = 4
        i = i + 1
        End If
    End If
    getDirectionArray = direction
End With
End Function
Function checkAround(nm_ As Integer) As Integer
'/* すでに通った分岐(別れ道)の中から、進める方向が残っている分岐を探す関数 */
    Dim i As Integer
    Dim mySum As Integer
    
    For i = nm_ - 1 To 0 Step -1
        mySum = 0
        If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeTop).LineStyle <> xlNone Or _
            flgArr(y(i) - 1)(x(i)) = 1 Then
            mySum = mySum + 1
        End If
        If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeRight).LineStyle <> xlNone Or _
            flgArr(y(i))(x(i) + 1) = 1 Then
            mySum = mySum + 1
        End If
        If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeBottom).LineStyle <> xlNone Or _
            flgArr(y(i) + 1)(x(i)) = 1 Then
            mySum = mySum + 1
        End If
        If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeLeft).LineStyle <> xlNone Or _
            flgArr(y(i))(x(i) - 1) = 1 Then
            mySum = mySum + 1
        End If

        If mySum < 4 Then
            checkAround = i
            Exit For
        End If
    Next i
End Function
Sub drawRoute()
'/*確定したルートの座標を格納した配列を一気に色付け */
Dim i As Integer, j As Integer, yy As Integer, xx As Integer
Dim rowEnd As Integer
    For i = 0 To nm
'       rowEnd = 2
        For j = 0 To 100
            If routeArr(i)(j) = "" Then Exit For
            yy = Val(Left(routeArr(i)(j), 2))
            xx = Val(Right(routeArr(i)(j), 2))
'            Cells(rowEnd, 14 + i).Value = routeArr(i)(j) '//デバッグ用にワークシートに書き出し
'            rowEnd = rowEnd + 1
            mazeArea.Cells(yy, xx).Interior.Color = RGB(255, 255, 0)
        Next j
    Next i
End Sub
Sub writeNumber()
    'Dim currentPosition As Range
    'Set currentPosition = mazeArea.Cells(y(nm), x(nm))
    'currentPosition.Value = nm
End Sub

 

Excel VBAでワークシート上に迷路を自動生成するマクロ

f:id:tdyu5021:20190505025631p:plain

くだらないExcelマクロを作るのが些細な趣味なのですが、この前軽い気持ちで作った「迷路を自動で生成して自動で正答ルートを色付けする」というマクロをTwitterで投稿したところ軽くバズりびっくりしました。せっかくなので、ここではその方法を紹介します。今回はまず「自動生成」のほうを紹介します。ソースコードは最後にあります。

 

「迷路を自動で生成して自動で正答ルートを色付けする」とは

まず、このマクロが何であるのかは、以下のツイート内の動画を見てもらえればわかると思います。


これは、Exceのセルを通路に、罫線を壁に見立てて、ランダムなルートの迷路を描画するマクロと、その迷路の正解ルートを自動で探索し描画するマクロの2つを実行したものです。

迷路を自動生成するアルゴリズム

決して大したものではないのですが、このツイートがバズったために「どうやって生成しているのか気になる」という類のコメントや、エンジニアや競技プログラミングをやられていると思わしき方からも「どんなアルゴリズムなのか」というコメントがちらほら寄せられました。

正直なところ、非プログラマーである私はアルゴリズムをまったく知らず、実際に皆様のコメントを見てから初めて、迷路生成/迷路解答アルゴリズムが存在するのだということを知ったくらいです。ですので、結局どの手法を使っているかわかりません。

生成のロジックは、おそらくいろんな方々が想像されるよりもかなりシンプルな仕組みです。以下の通りです。

(1)真っ白な10マス×10マスのセルを用意する
(2)開始地点として、一番左上のセルに通路を描画する
(3)現在地のセルの四方に通路ができているか否かを確認して、通路ができていない方向をランダムに選択しそのセルに通路を描画
(4)上記の(3)の処理を、四方が通路に囲まれて行き止まりになるか、またはゴールのセルの1つ手前に達するまで再帰処理でループさせる

まず、ここまでを動画にすると以下になります。イメージがつかみやすいでしょうか?

f:id:tdyu5021:20190505030651g:plain以下、続きです。
(5)既存の通路から新たに別の通路を開通させて上記の(3)~(4)の処理を再度行う
(6)上記(3)~(5)を繰り返し、10マス×10マスのセルをすべて埋めたら再帰処理のループを抜けて終了
(7)左上のセルの上部の罫線と右下のセルの下部の罫線を消して入り口出口を開通

以上です。アルゴリズムとしてはたったこれだけです。
ただ、非プログラマーの私としてはこれをどうやってExcelVBAの中で実装するかが大変でした。(結果、ものすごく膨大な時間がかかってしまいました…)行数もたかだか220行程度です。本職の方がやればすぐ終わると思います。

Excel VBAで実装する方法

では、実際にVBAでどう作ったのかをポイントを紹介します。ソースコードについては、最後にすべて記すのでそちらを参照してください。まず先ほどの
(3)現在地のセルの四方に通路ができているか否かを確認して、通路ができていない方向からランダムな方向を選択しそのセルを描画」の部分にふれてみます。

描画する前に、まず隣のセルに通路があるかを確認する方法

通路の判定はセル上のプロパティで行っていません。まず10×10のセルを2次元配列とみなし、配列変数にし、変数上で判定を行っています。デフォルトでは各座標の要素に0の値を入れておき、通路ができたらその座標の値を1にフラグオンします。
つまり、現在地の座標を基準に上下左右隣の座標が0ならその道を開通させる、というロジックです。

2次元配列の初期化

上述の2次元配列を初期化するためには次の記述を行います。下記のがy座標(=行)であり、青がx座標(=列)です。

arr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
arr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim i As Integer
   For i = 1 To 10
      arr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
   Next i

上記を見ると要素数はy座標12マス×x座標12マスとなっています。迷路のマスは10マス×10マスなので疑問に思うかもしれませんが、その理由は次の画像の通りです。2次元配列をセル上に可視化してみました。

f:id:tdyu5021:20190505031804p:plainあるセルから四方の配列要素の値が0か1かを判断するというロジックを使うといっても、壁側のセルの場合、壁の外を探索する必要ないので四方を調べる処理が使えません。しかし壁側セルだけに別の処理を書かせるとコードかなり煩雑になるので、壁側の外側にもy,x座標のマスを設けているのです。

隣のセルに通路を描画する

隣のセルに通路を描写するのは、後述のソースコード内に記載したfillRouteというプロシージャで行います。ただし、単純に道+壁を塗る処理だと以下のようになってしまうので、壁を開通させながら進まなければいけません。

f:id:tdyu5021:20190505031745p:plain
進んだ方向からの壁を開通させるには、セルから次に進む方向を決めた後、自分がもともといた方向の数値を引数に取ってfillRouteプロシージャを呼び出します(ソースコード中「'//次に進む方向を決定」のコメント以下を参照)。進む方向と数字の対応は以下の通りです。
1:上方向
2:右方向
3:下方向
4:左方向

次に進んだ方向がわかれば自分がもともといた場所もわかります。

隣のセルに通路を描画する再起処理を止める条件は?

先ほどのステップ(4)で「四方が通路に囲まれて行き止まりになるか、またはゴールのセルの1つ手前に達するまで再帰処理でループさせる」という書きました。後者は例えば次の画像を見てください(ゴールのセルはK11。その手前のK10に来たのでストップしている)

f:id:tdyu5021:20190505031945p:plain(※今書いていて思い始めましたが、ゴールセル手前まで到達したら再起をストップという処理は迷路生成ロジックそのものとしては不要だったなと思い始める。別に手前まで止めずとともゴールセル上をそのまま描画しても多分迷路は作れますね・・)

行き止まり到達後、新たなセルから再び通路描画を始める

行き止まりに達したあと、次は任意のセルからまた通路生成を開始します。開始するセルを選ぶ処理は、正直妥協しました・・次に開通するセルは、「まだ通路が描画されていないセルを左上から検索していき最初にヒットした場所にする」という単純な条件で選択しています。先程の図でいうとH2のセルです(下図参照)

f:id:tdyu5021:20190505032041p:plain

新たな通路描画の開始セルと既存の通路を開通させる

当然ですが、新たに生成した通路は既存の通路と開通させる必要があります。上記の画面でいえば、H2セルから始まった場合、G2セル側か、H3セル側の壁を開通させます。ソースコードを見てもらえればと思いますが、ここでは開通のために以下の処理をしています。
(1)配列direction()に壁がある方向の番号を格納
(2)関数getDirectionNumで、(1)で見つかった壁のうちどこに穴を開けるか、壁の方向(の番号)をランダムで取得
(3)その後、(2)で取得した開通先を引数に、最初に述べたfillRouteプロシージャで通路描画

これで行き止まりに達したらまた上記(1)~(3)を行います。10マス×10マスの迷路なので、通路を描画したセルが100個に到達したらExit Subしてマクロを終了します。

作ってみての感想

いま振り返りながら文書化してみると、もう少しシンプルに書けたり改良したりできたなと思うところはあります。特に行き止まりに達したあと、本来であれば新たに通路描画を開始するセルは以下の数だけ存在します(=既存の通路と接しているところ)

f:id:tdyu5021:20190505032308p:plainなので、「ランダムなx、y座標を生成させて、それが水色の部分に該当したらそこから描画を始める」という処理でもよかったかもしれません。

最後に1ステップずつ迷路を描画するGIF動画を置いておきます。今回迷路生成ロジックを説明しましたが、迷路を解くマクロは感覚的にその倍くらい苦労しました。これは次回解説します。

f:id:tdyu5021:20190505031147g:plain

 ソースコード

以下、今回の迷路生成マクロのソースコードです。多分標準モジュールにこのままコピペすれば使えるはずです。

Dim mazeArea As Range
Dim currentPosition As Range
Dim x As Integer, y As Integer
Dim cnt As Integer
Dim arr(11) As Variant
Const limit = 4
Sub initializing()
Application.ScreenUpdating = False
 
 '//埋まったセルの数を数えるをカウンタ
cnt = 0

'//迷路の範囲を定義&初期化
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))
mazeArea.Clear

'//マスが埋まっているかいないかを1か0で判定するための配列を初期化
arr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
arr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim i As Integer
For i = 1 To 10
    arr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i

'//自分の最初の座標
x = 1
y = 1

'//道の描画(今いるセルに色と罫をつける)
Call fillRoute(1)

'//次に描画する道(セル)に移動
Call move

End Sub
Sub move()
Dim up As Integer, rt As Integer, bt As Integer, lf As Integer
Dim sum1 As Integer, sum2 As Integer
Dim a As Integer
Dim b As Integer
Dim n As Integer
Dim direction() As Integer
Dim directionArray As Variant
Dim xx As Integer

Randomize

'//セルを100個塗ったら作成終了
If cnt > 99 Then
    mazeArea.Cells(1, 1).Borders(xlEdgeTop).LineStyle = xlNone
    mazeArea.Cells(10, 10).Borders(xlEdgeBottom).LineStyle = xlNone
    Application.ScreenUpdating = True
    Exit Sub
End If

'//隣のセルに移動できるかどうかを判定
up = arr(y - 1)(x)
bt = arr(y + 1)(x)
rt = arr(y)(x + 1)
lf = arr(y)(x - 1)
sum1 = up + bt + rt + lf
                
'//もし隣のセルがすべて埋まっていてこれ以上進めない場合、
'//あるいは、ゴールセルの1つ手前のセルに初めて来た場合に
'//新たな空白セルからスタート+任意の方向の壁を開通
If (sum1 = limit) Or (((y = 9 And x = 10) Or (y = 10 And x = 9)) And stopFlg = False) Then
    If (y = 9 And x = 10) Or (y = 10 And x = 9) Then stopFlg = True
    Dim i As Integer, j As Integer
    For i = 1 To 10
        For j = 1 To 10
            If arr(i)(j) = 0 Then
                up = arr(i - 1)(j)
                bt = arr(i + 1)(j)
                rt = arr(i)(j + 1)
                lf = arr(i)(j - 1)
                '//現在地セルの周りが何方向埋まっているかの数を格納
                sum2 = up + bt + rt + lf
                
                '//埋まっている方向(の番号)を配列に入れる
                ReDim direction(sum2 - 1) As Integer
                xx = 0
                If up = 1 Then
                    direction(xx) = 3 '//上方向が埋まってる場合
                    xx = xx + 1
                End If
                If bt = 1 Then
                    direction(xx) = 1  '//下方向が埋まってる場合
                    xx = xx + 1
                End If
                If rt = 1 Then
                    direction(xx) = 4 '//右方向が埋まってる場合
                    xx = xx + 1
                End If
                If lf = 1 Then
                    direction(xx) = 2 '//左方向が埋まってる場合
                End If
                
                y = i
                x = j
                Select Case sum2
                    Case 1
                        fillRoute (direction(xx))
                    Case 2
                        directionArray = Array(direction(0), direction(1))
                    Case 3
                        directionArray = Array(direction(0), direction(1), direction(2))
                    Case 4
                        directionArray = Array(direction(0), direction(1), direction(2), direction(3))
                End Select
                '//壁を開通させる方向を取得する関数
                num = getDirectionNum(directionArray, sum2)
                '//次の道を描画
                fillRoute (num)
                
                If Not cnt > 99 Then Call move
                Exit For
            End If
        Next j
    Next i
    
End If


'//次に進む方向を決定
n = Int(Rnd * 4) + 1
Select Case n
    Case 1 '//上
        '//もし移動先が進めないセルだったら進む方向は決定せず再帰
        If y = 1 Or arr(y - 1)(x) = 1 Then
            Call move
            Exit Sub
        Else
            a = -1
            b = 0
        End If
    Case 2 '//右
        If x = 10 Or arr(y)(x + 1) = 1 Then
            Call move
            Exit Sub
        Else
            a = 0
            b = 1
        End If
    Case 3 '//下
        If y = 10 Or arr(y + 1)(x) = 1 Then
            Call move
            Exit Sub
        Else
            a = 1
            b = 0
        End If
    Case 4 '//左
        If x = 1 Or arr(y)(x - 1) = 1 Then
            Call move
            Exit Sub
        Else
            a = 0
            b = -1
        End If
End Select

'//次の道の座標
y = y + a
x = x + b

'//次の道を描画
Call fillRoute(n)
'//Application.Wait [Now() + "0:00:00.1"] '//デバッグ用。描画の様子を1マスずつ確認するため

Call move

End Sub
Sub fillRoute(num As Integer)
    Set currentPosition = mazeArea.Cells(y, x)
    With currentPosition
        .BorderAround Weight:=xlThick, LineStyle:=xlContinuous
        Select Case num
            Case 1
                .Borders(xlEdgeBottom).LineStyle = xlNone
            Case 2
                .Borders(xlEdgeLeft).LineStyle = xlNone
            Case 3
                .Borders(xlEdgeTop).LineStyle = xlNone
            Case 4
                .Borders(xlEdgeRight).LineStyle = xlNone
        End Select
        .Interior.ColorIndex = xlAutomatic
        .Interior.Pattern = xlCrissCross
        .Interior.PatternThemeColor = xlThemeColorAccent4
        .Interior.PatternTintAndShade = 0.6
    End With
    '//描画済みの座標をフラグオン
    arr(y)(x) = 1
    cnt = cnt + 1
End Sub
Function getDirectionNum(ByVal directionArray_ As Variant, sum2_ As Integer) As Integer
'/*壁を開通する方向を決定する関数*/

Dim n As Integer, directionNum As Integer, flg As Boolean
    Randomize
    Do
        n = Int(Rnd * sum2_)
        directionNum = directionArray_(n)
        If y = 1 And directionNum = 3 Then
            flg = True
        ElseIf y = 10 And directionNum = 1 Then
            flg = True
        ElseIf x = 1 And directionNum = 2 Then
            flg = True
        ElseIf x = 10 And directionNum = 4 Then
            flg = True
        Else
            flg = False
        End If
    Loop While flg = True
    getDirectionNum = directionNum
End Function