Excel VBA質問箱 IV

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

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


12966 / 76734 ←次へ | 前へ→

【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

8 hits

【69270】VBAプログラミング 文哉 11/6/17(金) 6:07 質問
【69271】Re:VBAプログラミング UO3 11/6/17(金) 6:41 発言
【69273】Re:VBAプログラミング Jaka 11/6/17(金) 9:45 発言
【69278】あ〜、なんとなく解った。 Jaka 11/6/17(金) 12:54 発言
【69274】Re:VBAプログラミング SS 11/6/17(金) 9:49 発言
【69279】Re:VBAプログラミング SS 11/6/17(金) 13:07 発言
【69276】Re:VBAプログラミング UO3 11/6/17(金) 11:45 発言
【69277】Re:VBAプログラミング UO3 11/6/17(金) 12:29 発言
【69280】Re:VBAプログラミング UO3 11/6/17(金) 16:35 発言

12966 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free