今回困っているのは下のマクロで
(1)紺なら足跡を残し、青なら進んでいるセルだけ青にして前回の青の足跡は残さないで
(2)セルが紺の足跡でいっぱいになるまで、これを続けます。
この条件をここに追加しようと思ったのですが、なかなかうまく行きません。ヒントだけでも、何か名案がありましたらご回答お願いします。
Const IMAX As Long = 30 '最大 i 座標
Const JMAX As Long = 20 '最大 j 座標
Const NMAX As Long = 50 '最大ステップ数
Const motigomi As Long = 5 'ゴミ「○歩につき●個捨てる」数
Dim ip(MMAX) As Long '人の i 座標
Dim jp(MMAX) As Long '人の j 座標
Dim occ(IMAX, JMAX) As Long
Dim pre(IMAX, JMAX) As Integer
Dim post(IMAX, JMAX) As Integer
Sub ashiato()
Randomize
Cells.Clear
For n = 1 To NMAX 'ステップを進める
For m = 1 To 1
iprev = ip(m) '元いた位置
jprev = jp(m)
'移動先 (i, j) を決める
i = i - 1
'周期境界条件
If i > IMAX Then i = i - IMAX
If i < 1 Then i = i + IMAX
If j > JMAX Then j = j - JMAX
If j < 1 Then j = j + JMAX
'実際に移動
ip(m) = i
jp(m) = j
'色付けを更新
pre(i, j) = Int(motigomi * Rnd())
If pre(i, j) = 1 Then
Cells(i, j).Interior.color = RGB(10, 50, 100)
Else
Cells(iprev, jprev).Clear
Cells(i, j).Interior.color = RGB(40, 50, 400)
End If
Next
Next
End Sub
No.4ベストアンサー
- 回答日時:
おはようございます。
KenKen_SP です。専門家の yastak2006 さんがご回答されているのに、こんな拙いものを
出しても良いのだろうか??? ...と思いながら。
# 設計の流れとかよく知らないので #3 ご回答とか勉強になり
# ました^^
実は興味本位で書いてみたコードなので、オリジナルソースも全然使って
ませんし、拙いロジックなので実用途には使えそうもないと思いますが、
それなりに動きますので多少は参考になるかと思います。
シート Map を用意して実行して下さい。では。
Option Explicit
' Win32Api
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
' Human 構造体(キャラクラパラメータ定義)
Private Type Human
PosX As Long ' 位置 Column
PosY As Long ' 位置 Row
Value As Variant ' 値-->表示文字列
Direction As Long ' 移動方向
BackupColorIdx As Long ' 移動先セル背景色退避
BackupValue As Variant ' 移動先セル値退避
End Type
Private mWst As Worksheet ' マップのシート
Private mMap As Range ' 移動可能なマップ範囲Range
Private mGomiCnt As Range ' ゴミカウンター表示Range
Private mlngGomi As Long ' ゴミ捨て回数カウンター
Private Man() As Human ' 人間
' ワークシート設定
Private Const MAP_CEL_W = 4 ' セルの幅
Private Const MAP_CEL_H = 20 ' セルの高さ
Private Const BG_CLRIDX = 1 ' 背景色カラーインデックス
' マップ設定
Private Const MAPPOS = "$C$3" ' マップの基点セル
Private Const MAPSIZE_X = 30 ' マップ幅セル数
Private Const MAPSIZE_Y = 20 ' マップ高セル数
' アイテム設定
Private Const MAN_COUNT = 20 ' 配置人間数
Private Const MAN_CLRIDX = 5 ' 人間カラーインデックス
Private Const MAN_CAPTION = "人" ' 人間キャプション
Private Const MAN_ATOIDX = 25 ' 足跡カラーインデックス
Private Const GMI_CLRIDX = 39 ' ゴミカラーインデックス
Private Const GMI_CAPTION = "ゴ" ' ゴミキャプション
Private Const GOMIPOI_RATE = 50 ' ゴミを捨てる確率分母
Sub Main()
Dim i As Long
Dim intRes As Integer
On Error GoTo ERROR_HANDLER
Call Init
If MsgBox("中断するには [Ctrl]+[Break] です。", _
vbOKCancel + vbInformation, "準備完了") = vbOK Then
With Application
.Cursor = xlWait
.StatusBar = ""
.EnableCancelKey = xlErrorHandler
End With
Do
For i = 0 To MAN_COUNT - 1
Call MoveHuman(i)
Next
If IsComplete() Then Exit Do
Call Wait(100) '<-------------------------- ココで速さを調整して下さい
Loop
MsgBox "終了条件を満たしました。", vbInformation
End If
TERMINATE:
With Application
.Cursor = xlDefault
.EnableCancelKey = xlInterrupt
.StatusBar = False
End With
Exit Sub
ERROR_HANDLER:
If Err.Number = 18 Then
intRes = MsgBox("中断キーが押されました。中止しますか?", _
vbOKCancel + vbExclamation)
If intRes = vbCancel Then
Err.Clear
Resume
Else
Resume TERMINATE
End If
Else
MsgBox Err.Description, vbCritical
Resume TERMINATE
End If
End Sub
' 初期化
Private Sub Init()
Set mWst = Nothing
Set mMap = Nothing
mlngGomi = 0
ReDim Man(MAN_COUNT - 1)
' シート環境
Set mWst = ThisWorkbook.Worksheets("Map")
mWst.Activate
ActiveWindow.Zoom = 80 ' 表示倍率80%
Application.ScreenUpdating = False
With mWst.Cells
.Clear
.HorizontalAlignment = xlCenter
.Font.ColorIndex = 2 ' 2: White
.Font.Size = 9
.Interior.ColorIndex = BG_CLRIDX
.ColumnWidth = MAP_CEL_W
.RowHeight = MAP_CEL_H
End With
Call DrawMapField
End Sub
' マップ・人間の初期描写
Private Sub DrawMapField()
Dim r1 As Long, r2 As Long
Dim c1 As Long, c2 As Long
Dim i As Long
Dim lngManPosR As Long
Dim lngManPosC As Long
' マップ描写
With mWst.Range(MAPPOS)
.Value = "ゴミが捨てられた回数:"
.HorizontalAlignment = xlLeft
Set mGomiCnt = .Offset(0, 7)
With mGomiCnt
.Value = 0
.HorizontalAlignment = xlRight
End With
With .Offset(0, 8)
.FormulaR1C1 = "=IF(RC[-1]>0,REPT(""|"",RC[-1]),"""")"
.Font.Name = "MS Pゴシック"
End With
End With
Set mMap = mWst.Range(MAPPOS).Offset(2).Resize(MAPSIZE_Y, MAPSIZE_X)
With mMap
.Interior.ColorIndex = xlAutomatic
.Borders.Weight = xlThin
End With
' 人間描写
With mMap
' マップの座標
r1 = .Row: r2 = .Row + .Rows.Count - 1
c1 = .Column: c2 = .Column + .Columns.Count - 1
End With
i = 0 ' 人間配置カウンタ
While i < MAN_COUNT
Randomize
lngManPosR = Int((r2 - r1 + 1) * Rnd + r1)
lngManPosC = Int((c2 - c1 + 1) * Rnd + c1)
With mWst.Cells(lngManPosR, lngManPosC)
If .Value = "" Then
' パラメータ設定
Man(i).PosX = .Column
Man(i).PosY = .Row
Man(i).Value = MAN_CAPTION
Man(i).Direction = Int(4 * Rnd + 1)
Man(i).BackupColorIdx = .Interior.ColorIndex
Man(i).BackupValue = .Value
' 描写
.Interior.ColorIndex = MAN_CLRIDX
.Value = Man(i).Value
End If
i = i + 1
End With
Wend
Application.ScreenUpdating = True
End Sub
' 人間の移動
Private Sub MoveHuman(ByVal i As Long)
Dim rngNext As Range
Dim rngPrev As Range
Dim x As Long, y As Long
' 移動方向と移動量計算
Select Case Man(i).Direction
Case 1: x = 1 ' Right
Case 2: y = 1 ' Down
Case 3: x = -1 ' Left
Case 4: y = -1 ' Up
End Select
' 移動元・移動先セル取得
On Error Resume Next
Set rngPrev = mWst.Cells(Man(i).PosY, Man(i).PosX)
Set rngNext = mWst.Cells(Man(i).PosY, Man(i).PosX).Offset(y, x)
If Err Then ' エラー時は移動しない
Err.Clear
Set rngPrev = Nothing
Set rngNext = Nothing
Exit Sub
End If
On Error GoTo 0
' 当たり判定
If Not Intersect(mMap, rngNext) Is Nothing _
And rngNext.Value <> MAN_CAPTION Then
Randomize
With rngPrev
If Int(GOMIPOI_RATE * 100 * Rnd + 1) < 100 Then
' ゴミ捨て処理
.Interior.ColorIndex = GMI_CLRIDX
.Value = GMI_CAPTION
mlngGomi = mlngGomi + 1
mGomiCnt.Value = mlngGomi
Else
' 移動元の復元
.Value = Man(i).BackupValue
If .Value <> GMI_CAPTION Then
.Interior.ColorIndex = MAN_ATOIDX
Else
.Interior.ColorIndex = GMI_CLRIDX
End If
End If
End With
' 人間の再描写
With rngNext
' 移動先の情報を退避
Man(i).BackupColorIdx = .Interior.ColorIndex
Man(i).BackupValue = .Value
' 人間の移動描写
.Interior.ColorIndex = MAN_CLRIDX
.Value = Man(i).Value
Man(i).PosX = .Column
Man(i).PosY = .Row
End With
' 次の移動方向を決める約1/3の確率で方向変換
Randomize
If Int(300 * Rnd + 1) < 100 Then
Man(i).Direction = Int(4 * Rnd + 1)
End If
Else
' 障害物に当たったので方向転換(同一方向がでても無視)
Man(i).Direction = Int(4 * Rnd + 1)
End If
Set rngPrev = Nothing
Set rngNext = Nothing
DoEvents
End Sub
' 終了判定関数
Private Function IsComplete() As Boolean
Dim C As Range
IsComplete = True
For Each C In mMap
If C.Interior.ColorIndex = xlAutomatic Then
IsComplete = False
Exit For
End If
Next
End Function
' ウェイト処理
Private Sub Wait(ByVal Miliseconds As Long)
Dim t As Long
If Miliseconds > 0 Then
t = timeGetTime() + Miliseconds
While t > timeGetTime()
DoEvents
Wend
End If
End Sub
Σ( ̄口 ̄;)はっ これはなんなんですか・・・。
プログラムを動かしたとき、感動して鳥肌が立ちました。
VBで鳥肌が立ったのは初めてです。
”l”をゴミ数を表すバロメーターにしてしまっているところとか、すごい!!と思った。常人のアイデアではないですねぇ
ただ、もう少しこのプログラムを読むのに時間が必要と思いますので、質問がでてきたら、送ります★ほんとうに、本当にありがとうございましたo(*≧∇≦)ノ"
No.5
- 回答日時:
#3の回答の訂正を掲載します
用件定義× 正しくは 要件定義です
「Numeric = "abcde" '実行結果となる値を予想し入力する」の
Numericの値には"1234567890"が入ります。
失礼しました。
No.3
- 回答日時:
質問には直接関係が無いのですが、これから先に必要になると思うので
プログラムの作成手順を簡単に説明しておきます。
1.用件定義(仕様を定義する)
今回の場合は
・画面30X20において人を左から右へ移動させる
・壁に差し掛かったら、????
・5分の1の確率でごみを捨てる
*境界線判定が良く分からないのでコメントできませんでした。
2.画面設計
画面の要素をイメージ画像としてまとめる。
3.プログラム設計
処理の流れをフロー図でまとめる。
*用件定義に使った文章を線で繋ぐと早くできる
4.変数表、関数表を作成する
クラスを定義する場合は引数や戻り値などをまとめておく
使う変数のスコープ順に並べてまとめておく
変数や関数の命名規約は頭にプレフィックスをつける
例、グローバル変数 G_XXXXXX プライベート変数 M_XXXXXX
ラベル lblXXX テキストボックスtxtXXXX
意味を持たない命名はしないこと。
5.フローを元にコメントを作成
フロー図を元にコメントをコーディングしていく。
現段階では、難しい処理のところはコメントのままにする。
例えば、
private const strSample="1234567890abcde"
Dim Numeric as String
For count=1 to Len(strSample)
'文字列の中のcount番目(以下count)の文字を取得する
'文字が数値であれば変数Numericに退避する
Numeric = "abcde" '実行結果となる値を予想し入力する
Next
取り合えず難しい処理は後回しにして、処理の流れ図通りに組んでみる勿論、途中でエラーが発生しないように必要な値は直に入力してやる
こんな感じでプロジェクトは進んでいます。難しいところに時間をかけず、分かるところから順に進んでいけば良いと思います。
それにはまず、しっかりと理解することです。
お礼が遅くなってすみません・・・
理解が遅くて、せっかくのアドバイスなのに、ちゃんと読み込めていないのにお礼をするのは失礼になるのかと思い。
≫質問には直接関係が無いのですが、これから先に必要になると思うのでプログラムの作成手順を簡単に説明しておきます。
わあ、素晴らしいアドバイス!
ほとんど独学なので、こういう貴重な意見は大事にしています!
ありがとうございます、kenkenさん(^_^)
No.2
- 回答日時:
可読性に欠けるプログラムですね。
もっと細かく分ける癖をつけましょう。
問題の足跡を消す処理は
If pre(i, j) = 1 Then
Cells(i, j).Interior.color = RGB(10, 50, 100)
Else
Cells(iprev, jprev).Clear
Cells(i, j).Interior.color = RGB(40, 50, 400)
End If
にあります。
サイコロの目が1以外はすべてクリアーして青にしています。
条件にその場所の色を入れるか、該当座標のサイコロの値を入れない とだめですね。
・For文の1TO1は遅くなりますのでつけない方が良いでしょう。どうせ やるなら 1 TO 定数にしましょう。
・J座標の変数が更新されていません。同じ位置で良いのですか?
・全体的に言えることは不要な配列変数を使いすぎです。
メモリーが足りなくなります。
・見やすいようにインデントを付けると良いでしょう。
以上です。
ご親切なアドバイス、本当に、どうもありがとうございます。
返事が遅くなって申し訳ありません・・・。
≫For文の1TO1は遅くなりますのでつけない方が良いでしょう。どうせ やるなら 1 TO 定数にしましょう。
もとのプログラムは定数を使っていました。教えてgoo!で文字数に制限があったため、定数のコードを省きました。
≫・J座標の変数が更新されていません。同じ位置で良いのですか?
あ!!「i = i - 1’移動先を決める」の所ですよね。もとのプログラムには「j=j+1とj=j-1」(右か左にランダムに動く)があったのですが、上と同じ理由で省きました。
≫・全体的に言えることは不要な配列変数を使いすぎです。
メモリーが足りなくなります。
ですよね・・・改善します!!(><")
≫・見やすいようにインデントを付けると良いでしょう。
そうですね!!
ほんとうに大切なお時間を割いていただいてのアドバイスのおかげで、勉強させていただきました。
ありがとうございます。
No.1
- 回答日時:
プログラムの仕様が良く分かりません。
補足説明ねがいます。まずは何をしたいのかを箇条書きにしてみると良いですよ。
その仕様を満たす処理図を描いてみてプログラムの流れを大まかに掴むと、その後のコーディングが楽になります。
この回答への補足
そっか、箇条書きか!アドバイスありがとうございます!(^▽^)♪♪
そうですよね、まだ自分の中で混乱しています。
イメージとしては、
・青:人間 紺:置き去られたゴミ です。
・motigomiのサイコロをふって、確率1/5でゴミを捨てます。
・ゴミを捨てなければ、青(人間)はclear,紺(ゴミ)はそのままで次のステップです。
しかし、この上のマクロではすでに捨ててあるゴミの上を通った人間がゴミ(紺のセル)を消してしまっています。これがバグなんです。
この補足説明でわかっていただけたでしょうか?・・・(>_<)!
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBA処理追加 こちらでご教示頂いたのですが回答完了させてしまいましたのでこちらからまた質問させてく 2 2022/10/27 09:57
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたいの続き 5 2023/01/24 00:16
- Visual Basic(VBA) 数字が「0」の列を削除するため、下記のコードを実行しましたが、コンパイルエラーSubまたはFunct 3 2022/12/04 00:00
- Visual Basic(VBA) VBA 請求書自動作成 3 2022/04/24 01:58
- Excel(エクセル) VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。 4 2022/04/07 02:38
- Visual Basic(VBA) ワークシート内を検索 1 2022/12/19 23:46
- Visual Basic(VBA) 前回ご教授いただいたコードに覚えたてのループ処理で品名りんごAから順に20回for nextでループ 7 2023/01/13 22:01
- Visual Basic(VBA) 数式が消える 1 2023/03/19 16:55
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
ユーザーフォームに別シートか...
-
現在のブックを閉じないで、マ...
-
【VBA】マクロの入ったファイル...
-
Excel VBA 定義されたプロージ...
-
Excel-VBAのmsgBox()の不思議
-
VBA初心者 Ctrl+での操作、ボタ...
-
VBA 複数条件の分岐処理の上手...
-
エクセルのマクロについて教え...
-
VBAに詳しい方教えてください。
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
ExcelVBA シート名を複数セルか...
-
FileCopy時のエラー
-
VBAで各列の"+"と"o"の合計数を...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
VBA listBoxについて
-
VBAを使用した時間管理
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBAのコードを教えてください
-
【ExcelVBA】インデックスが有...
-
ExcelVBA シート名を複数セルか...
-
エクセルvbaについて
-
エクセルのマクロについて教え...
-
【VBA】マクロの入ったファイル...
-
VBA UserFormからの転記で
-
エクセルVBAの配列について
-
Excelで「Ctrl+c」、「Ctrl+v...
-
VBAコードについて教えてくださ...
-
ExcelのVBAコードについて教え...
-
Excel マクロについての相談
-
VBAで質問があります
-
VBAコードについて
-
【ExcelVBA】VBA実行でダイアロ...
-
Excel関数またはVBAでの質問に...
-
ExcelのVBAコードについて教え...
-
ExcelのVBAコードについて教え...
-
ExcelのVBAコードについて教え...
-
Outlookの「受信日時」「件名」...
おすすめ情報