シェイプの線であみだくじを作ってみました。
![](https://wata-ruch.com/wp-content/uploads/2024/07/あみだくじ_01.gif)
ざっくりとやっていることをメモします。
セル1つずつ順番に「線」のシェイプを作成しています。
'クリックしたシェイプの下のセルを取得
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
- 一番左の列に2~4本の横線をランダム位置に配置
- 次の列に前の列と重複しない位置に2~4本の横線をランダムに配置
重複判定には配列を使用しています。
'一つ前の配列を保存する配列
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
- 最初の縦線を赤色にする
- 一つ下に移動して横の線があれば横の線とその先の縦線を赤色にする
- 横の線が無ければ縦線を赤色にする
- これを一番下まで繰り返す
簡単なif文なのでコードは割愛します。
スポンサーリンク