Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4052 / 76734

←次へ　｜　前へ→


	【78310】Re:Randomwalk

β - 16/6/24(金) 0:46 -


	引用なし

	パスワード

▼kinoko さん：

>一度通ったところは赤、二度目は青色っていう

ということなら色相返還をしなくてもいいので、アップした、共通モジュールプロシジャは必要なく
以下のみでＯＫですね。
色の順番は　★のところで規定しています。

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Sub Sample2()
　　Dim i As Long
　　Dim j As Long
　　Dim n As Long
　　Dim t As Long
　　Dim l As Long
　　Dim r As Long
　　Dim b As Long
　　Dim a As Range
　　Dim rtn As Long
　　Dim pos As Variant
　　Dim color As Variant
　　
　　Cells.Clear
　　
　　Randomize

　　Cells.RowHeight = 5
　　Cells.ColumnWidth = 0.5
　　
　　With ActiveWindow.VisibleRange
　　　　t = .Row
　　　　b = .Rows.Count
　　　　l = .Column
　　　　r = .Columns.Count
　　End With
　　
　　color = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbCyan, vbBlack, vbRed)　 '★
　　
　　'最初のセルを選定
　　i = Int((b - t + 1) * Rnd + t)
　　j = Int((r - l + 1) * Rnd + l)
　　Cells(i, j).Interior.color = vbRed
　　
　　Do
　　　　
　　　　rtn = GetAsyncKeyState(16) 'シフトキー
　　　　rtn = rtn And &H80000000
　　　　If rtn <> 0 Then Exit Do
　　　　
　　　　If i = l And j = t Then　　 '領域の左上隅
　　　　　　pos = Array(5, 7, 8)
　　　　ElseIf i = r And j = t Then '領域の右上隅
　　　　　　pos = Array(4, 6, 7)
　　　　ElseIf i = b And j = l Then '領域の左下隅
　　　　　　pos = Array(2, 3, 5)
　　　　ElseIf i = b And j = r Then '領域の右下隅
　　　　　　pos = Array(1, 2, 6)
　　　　ElseIf i = t Then　　　　　 '領域の上辺
　　　　　　pos = Array(4, 5, 6, 7, 8)
　　　　ElseIf i = b Then　　　　　 '領域の下辺
　　　　　　pos = Array(1, 2, 3, 4, 5)
　　　　ElseIf j = l Then　　　　　 '領域の左端
　　　　　　pos = Array(2, 3, 5, 7, 8)
　　　　ElseIf j = r Then　　　　　 '領域の右端
　　　　　　pos = Array(1, 2, 4, 6, 7)
　　　　Else
　　　　　　pos = Array(1, 2, 3, 4, 5, 6, 7, 8)
　　　　End If
　　　　
　　　　n = Int((UBound(pos) - LBound(pos) + 1) * Rnd + LBound(pos))
　　　　n = pos(n)
　　　　
　　　　'セル移動
　　　　Select Case n
　　　　　　Case 1: i = i - 1: j = j - 1
　　　　　　Case 2: i = i - 1
　　　　　　Case 3: i = i - 1: j = j + 1
　　　　　　Case 4: j = j - 1
　　　　　　Case 5: j = j + 1
　　　　　　Case 6: i = i + 1: j = j - 1
　　　　　　Case 7: i = i + 1
　　　　　　Case 8: i = i + 1: j = j + 1
　　　　End Select
　　　　
　　　　With Cells(i, j).Interior
　　　　　　If .ColorIndex = xlNone Then
　　　　　　　　.color = vbRed　　　　　'最初は赤
　　　　　　Else
　　　　　　　　n = WorksheetFunction.Match(.color, color, 0)
　　　　　　　　.color = color(n)
　　　　　　End If
　　　　End With
　　　　
　　　　Sleep 10
　　　　DoEvents
　　　　
　　Loop
　　
End Sub

11 hits

▼

【78305】Randomwalk kinoko 16/6/23(木) 17:16