【VBA】エクセルであみだくじ

シェイプの線であみだくじを作ってみました。

ざっくりとやっていることをメモします。

縦に線を引く
横線をランダムに配置する
当たり・はずれ判定

縦に線を引く

セル１つずつ順番に「線」のシェイプを作成しています。

    'クリックしたシェイプの下のセルを取得
    Dim shpRng As Range
    Set shpRng = ActiveSheet.Shapes(Application.Caller).TopLeftCell
    
    '縦線を引く
    Dim i As Long, j As Long
    For i = 0 To 3
        For j = 0 To 10
            '線の始点位置
            Dim x1 As Double, y1 As Double
            x1 = shpRng.Offset(0, i).Left
            y1 = shpRng.Offset(3, 0).Offset(j).Top
            '線の終点位置
            Dim x2 As Double, y2 As Double
            x2 = shpRng.Offset(0, i).Left
            y2 = shpRng.Offset(4, 0).Offset(j).Top
            '線のシェイプを作成
            Dim shp As Shape
            Set shp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
            shp.name = "あみだ縦" & i & j
            shp.Line.ForeColor.RGB = rgbDodgerBlue '線の色
            '線を引いているように見せるための遅延
            Application.Wait [Now()] + 20 / 86400000
        Next j
    Next i

横線をランダムに配置する

一番左の列に２～４本の横線をランダム位置に配置
次の列に前の列と重複しない位置に２～４本の横線をランダムに配置

重複判定には配列を使用しています。

    '一つ前の配列を保存する配列
    Dim arr0() As Long
    ReDim arr0(1 To 4)

    Dim ia As Long
    For ia = 1 To 3
        'ランダム値生成
        Dim maxNum As Long
        maxNum = WorksheetFunction.RandBetween(2, 4)
    
        '重複しないランダム値Function
        Dim arr() As Long
        ReDim arr(1 To maxNum)
    
        Dim n As Long: n = 1
        Do Until n > maxNum
            Dim buf As Long
            buf = WorksheetFunction.RandBetween(1, 10)
            If Not ExistsNumber(buf, arr0) Then
                If Not ExistsNumber(buf, arr) Then
                    arr(n) = buf
                    n = n + 1
                End If
            End If
        Loop
        '一つ前の配列として保存
        arr0 = arr

        '配列から数値を取り出す
        Dim k As Long
        For k = 1 To UBound(arr)
            '線の始点位置
            x1 = ActiveSheet.Shapes("あみだ縦" & ia - 1 & arr(k)).Left
            y1 = ActiveSheet.Shapes("あみだ縦" & ia - 1 & arr(k)).Top
            '線の終点位置
            x2 = ActiveSheet.Shapes("あみだ縦" & ia - 1 & arr(k)).Left + Range("A1").Width
            y2 = ActiveSheet.Shapes("あみだ縦" & ia - 1 & arr(k)).Top
            '線のシェイプを作成
            Set shp = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
            shp.name = "あみだ横" & ia & arr(k)
            shp.Line.ForeColor.RGB = rgbDodgerBlue '線の色
            '線を引いているように見せるための遅延
            Application.Wait [Now()] + 30 / 86400000
        Next
    Next ia

'配列内に重複する値があるときはtrueを返す
Private Function ExistsNumber(buf As Long, num() As Long) As Boolean
    
    Dim i As Long
    For i = 1 To UBound(num)
        If buf = num(i) Then
            ExistsNumber = True
            Exit Function
        End If
    Next
     
    ExistsNumber = False
     
End Function