Excel VBA質問箱 IV

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

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


2223 / 13645 ツリー ←次へ | 前へ→

【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 発言[未読]

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

引用なし
パスワード
   VBAでランダムウォークというのをプログラミングしたいのですが、
(10,10)のセルを原点に右上のセルに1、右のセルに2、右下のセルに3、下のセルに4、左下のセルに5、左のセルに6、左上のセルに7、上のセルに8、原点のセルを9と乱数をふるというやり方でやっていきたいのですがプログラム初心者で分からず苦戦しております。


Sub randomwalk()

dim r as integer
dim c as integer

activesheet.cells.select
r=10
c=10
cells(r,c).select
randomize    以降の部分です。

言葉でうまく説明できずに質問するのは大変申し訳ないのですが、よろしくお願いいたします。酔っ払いがふらふら歩いていく感じをどんどん黒に塗りつぶされていくセルで表現していきたいのです。

【69271】Re:VBAプログラミング
発言  UO3  - 11/6/17(金) 6:41 -

引用なし
パスワード
   ▼文哉 さん:

おはようございます。

わたしも「うまく説明できない」かもしれませんが。
考え方の第一歩は、動きの方向、「↓」「↑」「←」「→」、この4種類に対する数値を
仮に1,2,3,4としますと、通常の場所にいる場合は、1〜4の4つから1つ取り出す、
第1列目にいるばあいは3をのぞいた1,2,4から1つ取り出す、最終列にいる場合は・・・・
こんなことから考えられてはいかがでしょう。

【69273】Re:VBAプログラミング
発言  Jaka  - 11/6/17(金) 9:45 -

引用なし
パスワード
   良く解ってないけど見本。

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub aaaa()
Dim 上下左右 As Long, 歩 As Long

Cells(10, 10).Select
Sleep 200

Randomize
上下左右 = Int((4 * Rnd) + 1)
歩 = Int((10 * Rnd) + 1)
With ActiveCell
  For i = 1 To 歩
    If 上下左右 = 1 Then
      If ActiveCell.Row > 1 Then
       ActiveCell.Offset(-1).Select
      Else
       Exit For
      End If
    ElseIf 上下左右 = 2 Then
      If ActiveCell.Row < Rows.Count Then
       ActiveCell.Offset(1).Select
      Else
       Exit For
      End If
    ElseIf 上下左右 = 3 Then
      If ActiveCell.Column > 1 Then
       ActiveCell.Offset(, -1).Select
      Else
       Exit For
      End If
    ElseIf 上下左右 = 4 Then
      If ActiveCell.Column < Columns.Count Then
       ActiveCell.Offset(, 1).Select
      Else
       Exit For
      End If
    End If
    DoEvents
    Sleep 100
  Next
End With
End Sub

【69274】Re:VBAプログラミング
発言  SS  - 11/6/17(金) 9:49 -

引用なし
パスワード
   ▼文哉 さん:

こんにちは、面白そうなので作ってみました。
自分の確認し易さで処理を作ってありますので
質問の内容と違う点があるかと思いますが
参考になればと思います。

Sub randomwalk()

  Dim r As Integer, dr As Integer
  Dim c As Integer, dc As Integer
  Dim n As Integer
  Dim i As Long
  Randomize
  With ActiveSheet
    .Cells.Interior.ColorIndex = xlNone
    r = 10
    c = 10
    .Cells(r, c).Interior.ColorIndex = 3
    For i = 1 To 50
      '乱数発生させる
      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 Or r + dr <= .Rows.Count And _
          c + dc >= 1 Or c + dc <= .Columns.Count Then
        c = c + dc
        r = r + dr
      End If
      '移動→色塗りで表現
      .Cells(r, c).Interior.ColorIndex = i Mod 10 + 3
      '時間調整0.1秒
      Application.Wait [ Now() + "00:00:00.1"]
    Next i
  End With
End Sub

>VBAでランダムウォークというのをプログラミングしたいのですが、
>(10,10)のセルを原点に右上のセルに1、右のセルに2、右下のセルに3、下のセルに4、左下のセルに5、左のセルに6、左上のセルに7、上のセルに8、原点のセルを9と乱数をふるというやり方でやっていきたいのですがプログラム初心者で分からず苦戦しております。
>
>
>Sub randomwalk()
>
>dim r as integer
>dim c as integer
>
>activesheet.cells.select
>r=10
>c=10
>cells(r,c).select
>randomize    以降の部分です。
>
>言葉でうまく説明できずに質問するのは大変申し訳ないのですが、よろしくお願いいたします。酔っ払いがふらふら歩いていく感じをどんどん黒に塗りつぶされていくセルで表現していきたいのです。

【69276】Re:VBAプログラミング
発言  UO3  - 11/6/17(金) 11:45 -

引用なし
パスワード
   ▼文哉 さん:

こんにちは

テーマがおもしろいので、ちょっと遊んでみました。
文哉さんの意図は「お掃除ロボット」のようなスムーズな動きかもしれませんが
「よっぱらいの千鳥足」をイメージしています。
壁際では、壁に向かって進んで頭をぶつけることもあると思いますし、一歩踏み出して
よろよろっと、そんな感じをだせないかなと。

まだ、未完成というか、以下の点が気に入らないのですが。
・だんだん意識が暗くなっていくことをイメージして、色合いを濃くしていってるんですが
 今は4段階ぐらい、これを、もう少し細かな移り変わりにできたらと。
・左右上下に移動方向を限定しているつもりなんですが、斜めにも移動。バグでしょうね。

なお、実行中に、任意の文字を入力すれば終了します。

Sub 酔っ払い()
  Dim myRGB As Integer
  Dim myRow As Long, myCol As Long
  Dim x As Long, y As Long, z As Long, i As Long
  Dim rtn As Long, svColor As Long, mySeq As Long
  
  Cells.Clear
  myRGB = 200 '開始時の色合い
  
  Do
    Sleep 50
    DoEvents
    DoEvents
    
    With ActiveCell
      myRow = .Row
      myCol = .Column
    End With

    x = Int((1 - (-1) + 1) * Rnd + (-1))
    y = Int((1 - (-1) + 1) * Rnd + (-1))
    
    If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
    If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
    
    If x <> 0 Or y <> 0 Then ActiveCell.Offset(y, x).Activate
    With ActiveCell
      svColor = RGB(myRGB, myRGB, myRGB)
      For i = 1 To 10
        
        .Interior.Color = vbBlack
        Sleep 30
        DoEvents
        .Interior.Color = svColor
        Sleep 30
        DoEvents
        
      Next
      .Interior.Color = svColor
      mySeq = mySeq + 1
      .Value = mySeq
      .ShrinkToFit = True '縮小して全てを表示
      .Font.Color = RGB(255, 255, 255) '文字色は白抜き
      myRGB = myRGB - 1 '次の色用

    End With
  Loop
  
End Sub

【69277】Re:VBAプログラミング
発言  UO3  - 11/6/17(金) 12:29 -

引用なし
パスワード
   ▼文哉 さん:

一応、色合いの多段階変化【以外】の改訂版です。
もうちょっと、よろよろかんを出してみましたが、さて、どうでしょう。
斜め移動をなくした結果、移動選択肢が少なくなって、動きが少なくなっています。

なお、途中で Shiftキーをおして終了させるようにしています。
ただ、すぐにキーを認識してくれる場合となかなか認識してくれない場合が
あります。ポンポンと2回ほど押すと認識確立が高くなりますが、あまりに
何回もおしていると、Windowsからメッセージがでるかもしれません。

どうしてもとまらない場合は、任意の文字を入力してください。
スペースでもいいです。要は、編集モードにしてマクロ実行を強制的に中断。

Option Explicit

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

Sub 酔っ払い2()
  Dim myRGB As Integer
  Dim myRow As Long, myCol As Long
  Dim x As Long, y As Long, z As Long, i As Long
  Dim rtn As Long, svColor As Long, mySeq As Long
  
  Randomize
  Cells.Clear
  myRGB = 223 '開始時の色合い
  
  Do
    rtn = GetAsyncKeyState(16) 'Shiftキー
    If rtn <> 0 Then Exit Do
    
    Sleep 500
    DoEvents
    
    With ActiveCell
      myRow = .Row
      myCol = .Column
    End With

    z = Int((5 - 1 + 1) * Rnd + 1)

    Select Case z
    
      Case 1
        x = 0: y = 0
      Case 2
        x = 0: y = 1
      Case 3
        x = 0: y = -1
      Case 4
        x = 1: y = 0
      Case 5
        x = -1: y = 0
    End Select

    If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
    If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
    
    ActiveCell.Offset(y, x).Activate
    
    With ActiveCell
      svColor = RGB(myRGB, myRGB, myRGB)
      For i = 1 To 10
        
        .Interior.Color = svColor
        Sleep 30
        DoEvents
        .Interior.Color = vbWhite
        Sleep 30
        DoEvents
        
      Next
      
      Sleep 500
      .Interior.Color = svColor
      mySeq = mySeq + 1
      .Value = mySeq
      .ShrinkToFit = True '縮小して全てを表示
      .Font.Color = RGB(255, 255, 255) '文字色は白抜き
      myRGB = myRGB - 1 '次の色用

    End With
  Loop
  
  With ActiveCell
    .Value = "轟沈 爆睡"
    .Interior.Color = vbBlack
  End With
  
End Sub

【69278】あ〜、なんとなく解った。
発言  Jaka  - 11/6/17(金) 12:54 -

引用なし
パスワード
   他の回答を見てなんとなく解りました。
ゲームとかのロジックですね。
再帰使うんじゃないかと思います。

しか〜し、あまりにも内臓が痛いので(場所胃から胸辺り他)
早退します。
ので、他の回答者の返信を当てにしてください。
先ほど見てもらおうとした病院に電話したら、診察は午前中だって....。
最近は午前中しか診察しない病院が増えたよな、まったく。

【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

【69280】Re:VBAプログラミング
発言  UO3  - 11/6/17(金) 16:35 -

引用なし
パスワード
   ▼文哉 さん:

こんにちは

やはり、GetAsyncKeyState が不安定です。
で、何回もキーを押すとPC全体が、変になる現象もでましたので、この制御は撤回し
かわりに「おやすみ」プロシジャを用意しました。これを実行すれば、千鳥足の徘徊は
終了します。(マクロショートカットキーに登録して実行すると操作しやすいかも)

で、本体の「酔っ払い」ですが、第三版として、リバイス。
移動方向の制御は変更していませんが、GetAsyncKeyState制御の撤回に加え、
千鳥足イメージを、すこし強調してみました。

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim StopLoop As Boolean

Sub 酔っ払い3()
  Dim myRGB As Integer
  Dim myRow As Long, myCol As Long
  Dim x As Long, y As Long, z As Long, i As Long
  Dim rtn As Long, svColor As Long, mySeq As Long
  Dim myTrace As Long
  
  Randomize
  Cells.Clear
  myTrace = RGB(&HC0, &HC0, &HC0) '軌跡の色 薄いグレー
  StopLoop = False
  
  Do
    If StopLoop Then Exit Do
  
    For i = 1 To 30
      With ActiveCell
        myRow = .Row
        myCol = .Column
      End With
  
      z = Int((5 - 1 + 1) * Rnd + 1)
  
      Select Case z
    
        Case 1
          x = 0: y = 0
        Case 2
          x = 0: y = 1
        Case 3
          x = 0: y = -1
        Case 4
          x = 1: y = 0
        Case 5
          x = -1: y = 0
      End Select
  
      If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
      If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
      
      With ActiveCell
        .Interior.Color = myTrace
        .Offset(y, x).Activate
      End With
      
      With ActiveCell
        mySeq = mySeq + 1
        .Value = mySeq
        .ShrinkToFit = True '縮小して全てを表示
        .Font.Color = RGB(255, 255, 255) '文字色は白抜き
        .Interior.Color = vbBlack
      End With
      
      Sleep 100
      DoEvents
      
    Next
    
    With ActiveCell

      For i = 1 To 20
        .Interior.Color = vbWhite
        Sleep 20
        DoEvents
        .Interior.Color = vbBlack
        Sleep 20
        DoEvents
      Next
   
      Sleep 500
      DoEvents

    End With
    
  Loop
 
  With ActiveCell
    .Value = "轟沈 爆睡"
  End With
 
End Sub

Sub おやすみ()
  StopLoop = True
End Sub

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