Excel VBA質問箱 IV

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

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


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

12970 / 76738

←次へ　｜　前へ→


	【69279】Re:VBAプログラミング

SS - 11/6/17(金) 13:07 -


	引用なし

	パスワード

▼文哉さん：

先ほどの条件間違えていました。
If r + dr >= 1 And r + dr <= .Rows.Count And _
　　　 c + dc >= 1 And c + dc <= .Columns.Count Then
となります。
始めたら面白かったので軌跡表現も作成してみました。
重複箇所の判定が思いつかなかったので範囲全体を配列に
取っており不恰好です。軌跡全部の再描画は避けました。
これも参考になればとおもいます。
あと前回移動方向による重み付けもして見ました。

Sub randomwalk_2()

　　Dim r As Long, dr As Integer, tr As Long, mr As Long
　　Dim c As Long, dc As Integer, tc As Long, mc As Long
　　Dim n As Integer, LM As Integer
　　Dim i As Long, j As Long, k As Long
　　Dim nt As Integer
　　Dim AD As Variant
　　Dim WS As Variant
　　
　　Randomize
　　k = 30　　　'長さ
　　mr = 100　　'行範囲
　　mc = 100　　'列範囲
　　nt = 300　　'繰り返し回数
　　ReDim AD(1 To k)
　　With ActiveSheet
　　　　With .Cells
　　　　　　.Interior.ColorIndex = xlNone
　　　　　　.ClearContents
　　　　End With
　　　　WS = .Range(.Cells(1, 1), .Cells(mr, mc)).Value
　　　　
　　　　r = 30
　　　　c = 30
　　　　With .Cells(r, c)
　　　　　　.Interior.ColorIndex = 1
　　　　　　AD(1) = .Address
　　　　　　WS(r, c) = WS(r, c) + 1
　　　　　　LM = 9
　　　　End With
　　　　For i = 1 To nt
　　　　　　'乱数発生させる
　　　　　　n = rndMove(LM)
　　　　　　LM = n
　　　　　　'n = Int(Rnd * 9) + 1
　　　　　　'乱数から動き量を導く
　　　　　　Select Case n
　　　　　　　　Case 1: dr = -1: dc = 1
　　　　　　　　Case 2: dr = 0: dc = 1
　　　　　　　　Case 3: dr = 1: dc = 1
　　　　　　　　Case 4: dr = 1: dc = 0
　　　　　　　　Case 5: dr = 1: dc = -1
　　　　　　　　Case 6: dr = 0: dc = -1
　　　　　　　　Case 7: dr = -1: dc = -1
　　　　　　　　Case 8: dr = -1: dc = 0
　　　　　　　　Case 9: dr = 0: dc = 0
　　　　　　End Select
　　　　　　'移動可能か判断
　　　　　　If r + dr >= 1 And r + dr <= mr And _
　　　　　　　　　　c + dc >= 1 And c + dc <= mc Then
　　　　　　　　c = c + dc
　　　　　　　　r = r + dr
　　　　　　End If
　　　　　　'移動(消去）
　　　　　　If AD(k) <> "" Then
　　　　　　　　tr = .Range(AD(k)).Row
　　　　　　　　tc = .Range(AD(k)).Column
　　　　　　　　WS(tr, tc) = WS(tr, tc) - 1
　　　　　　　　If WS(tr, tc) = 0 Then
　　　　　　　　　　.Cells(tr, tc).Interior.ColorIndex = xlNone
　　　　　　　　End If
　　　　　　End If
　　　　　　'データ入替
　　　　　　For j = k To 2 Step -1
　　　　　　　　AD(j) = AD(j - 1)
　　　　　　Next j
　　　　　　'移動
　　　　　　If nt - i + 1 >= k Then
　　　　　　　　With .Cells(r, c)
　　　　　　　　　　WS(r, c) = WS(r, c) + 1
　　　　　　　　　　AD(1) = .Address
　　　　　　　　　　.Interior.ColorIndex = 1
　　　　　　　　End With
　　　　　　End If
　　　　　　'時間調整0.1秒
　　　　　　Application.Wait [ Now() + "00:00:00.02"]
　　　　Next i
　　End With
End Sub

Function rndMove(ByVal LM As Integer)
　　Dim tmp
　　Dim MoveData(1 To 9) As Variant
　　Randomize
　　MoveData(1) = "112237889"
　　MoveData(2) = "112233489"
　　MoveData(3) = "122334459"
　　MoveData(4) = "233445569"
　　MoveData(5) = "344556679"
　　MoveData(6) = "455667789"
　　MoveData(7) = "146677889"
　　MoveData(8) = "112677889"
　　MoveData(9) = "123456789"
　　tmp = Int(Rnd * 9) + 1
　　rndMove = Val(Mid(MoveData(LM), tmp, 1))
End Function

7 hits

▼

【69270】VBAプログラミング 文哉 11/6/17(金) 6:07