
↓こちらの質問者様からありました内容のテキストバージョンを作成したいと考えています。
https://oshiete.goo.ne.jp/qa/1530615.html
ゲームの桃太郎電鉄の次の目的駅を決めるルーレットってありますが、まさにあんな感じです。
ExcelVBAで可能でしょうか?
10×10の100マスに記載されたテキストからランダムで色の枠が動き、決定後に点滅するようなイメージです。
皆様のお知恵を拝借願えませんでしょうか。

No.8ベストアンサー
- 回答日時:
テストデータを編集しやすいように別シートに置くバージョンです。
☆ インストール方法
①「ルーレット」と「データ」シートを作成します。
② コードをそれぞれの場所に張付けます。
③「シート初期化」マクロを実行します。
④「データ」シートのA列にテキストを入力します
☆ 使い方
・「Start」ボタンをクリックすると「Stop」ボタンに変わり、対象文がクリアされ、色が変化しながら隣のセルに移っていきます
・「Stop」ボタンをクリックすると移動速度がだんだん遅くなって(遅くなり方がランダムです)止まると「Start」ボタンに戻って対象文が表示されます。
・ ルーレットが動いているときに数字部分をクリックすると、その文章が表示されます。
以下コードです
☆ 標準モジュールの Module1 にコピペして下さい。
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public 停止動作 As Boolean
Sub ルーレット()
Const 制限間隔 As Long = 1000
Dim 間隔 As Double
Dim 行 As Long
Dim 列 As Long
Dim 色 As Long
間隔 = 0.1
行 = 2
列 = 2
Range("B2:K11").Interior.Color = RGB(255, 255, 255)
停止動作 = False
Do While 間隔 < 制限間隔
Cells(行, 列).Interior.Color = Int(Rnd() * 16777216)
If 停止動作 Then
Range("B13").Value = ""
間隔 = 間隔 * (1 + Rnd() * 0.3)
End If
DoEvents
Sleep 間隔
DoEvents
Cells(行, 列).Interior.ColorIndex = xlNone
列 = 列 + 1
If 列 > 11 Then
列 = 2
行 = 行 + 1
If 行 > 11 Then 行 = 2
End If
Loop
Cells(行, 列).Interior.Color = RGB(255, 0, 0)
Call テキスト表示(Cells(行, 列).Value)
Range("J13").Value = "Start"
End Sub
Sub テキスト表示(番号 As Long)
Sheets("ルーレット").Range("B13:H13").Value = Sheets("データ").Cells(番号, 1).Value
End Sub
Sub シート初期化()
Dim 行 As Long
Dim 列 As Long
Dim 番号 As Long
Application.EnableEvents = False
Sheets("ルーレット").Select
ActiveSheet.Protect UserInterfaceOnly:=True
ActiveWindow.DisplayHeadings = False
ActiveWindow.FreezePanes = False
Cells.Delete Shift:=xlUp
Cells.ColumnWidth = 0
Range("A:A,L:L").ColumnWidth = 0.77
Columns("B:K").ColumnWidth = 6.88
Cells.RowHeight = 0
Range("1:1,12:12,14:14").RowHeight = 7.5
Range("2:11,13:13").RowHeight = 30
Cells.Interior.Color = RGB(255, 255, 255)
Cells.VerticalAlignment = xlCenter
Cells.HorizontalAlignment = xlCenter
With Cells.Font
.Name = "BIZ UDゴシック"
.Size = 18
.Bold = True
End With
For 行 = 2 To 11
For 列 = 2 To 11
番号 = 番号 + 1
Cells(行, 列).Value = 番号
Next
Next
Range("B2:K11").Borders.Weight = xlThin
With Range("B13:H13")
.HorizontalAlignment = xlGeneral
.MergeCells = True
.Borders.Weight = xlThin
End With
Range("A1").Select
Call ボタン作成("j13:K13", "Start")
Range("B13:H13").Select
Application.EnableEvents = True
End Sub
Sub ボタン作成(範囲 As String, 文字 As String)
With Range(範囲)
With .Borders(xlEdgeLeft)
.Weight = xlMedium
.Color = RGB(255, 255, 255)
End With
With .Borders(xlEdgeTop)
.Weight = xlMedium
.Color = RGB(255, 255, 255)
End With
With .Borders(xlEdgeBottom)
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeRight)
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
.Interior.Color = RGB(192, 192, 192)
.MergeCells = True
.Value = 文字
End With
End Sub
☆ ルーレットシートモジュール にコピペして下さい。
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Row
Case 2 To 11
Select Case Target.Column
Case 2 To 11
Application.EnableEvents = False
If 停止動作 = False Then
Call テキスト表示(Cells(Target.Row, Target.Column).Value)
End If
Range("B13:H13").Select
Application.EnableEvents = True
Case Else
Application.EnableEvents = False
Range("B13:H13").Select
Application.EnableEvents = True
End Select
Case 13
If Target.Column = 10 Then
Application.EnableEvents = False
Range("B13:H13").Select
Application.EnableEvents = True
If Range("J13").Value = "Stop" Then
停止動作 = True
Else
Range("J13").Value = "Stop"
Call ルーレット
End If
End If
Case Else
Application.EnableEvents = False
Range("B13:H13").Select
Application.EnableEvents = True
End Select
End Sub
☆ ThisWorkbook にコピペして下さい。
Option Explicit
Private Sub Workbook_Open()
Sheets("ルーレット").Select
ActiveSheet.Protect UserInterfaceOnly:=True
End Sub
凄い、、ご回答ありがとうございます。いろいろと条件や環境を変えてみたいに参考にさせていただきます。同じような組み方ばかりの自分では思いつきませんでさした。無限のやり方がありますね。
VBAだけでなくプログラミングの面白さも感じました。
いま実行できる環境がないのですが、取り急ぎの御礼、ベストアンサーとさせていただきます。ありがとうございました。
No.9
- 回答日時:
No.8 までの補足
ランダムにマスを選択する場合はテキスト全体を表示出来ないので、別枠に表示するやり方をしましたが、
多分、下図のように横は1列に縦は奇数行にして文章がスクロールするようにし真ん中が対象にした方が良い気がしました。いかがでしょうか?

No.7
- 回答日時:
No.6 の補足
使い方
・「Start」ボタンをクリックすると「Stop」ボタンに変わり、対象文がクリアされ、色が変化しながら隣のセルに移っていきます(移動はランダムではありませんが早すぎて飛んで見えると思います)
・「Stop」ボタンをクリックすると移動速度がだんだん遅くなって(遅くなり方がランダムです)止まると「Start」ボタンに戻って対象文が表示されます。
・ 上部の数字部分をクリックすると、その数字の文章のセルが選択され見る事が出来ます。(ルーレットが動いていても可能です)
・ 文章データはリンクの方が良いかもしれません
No.6
- 回答日時:
お気に召さないようなので、元のリンク先を参考に作り直してみました。
①「ルーレット」というシートを作成します。
② コードをそれぞれの場所に張付けます。
③「シート初期化」マクロを実行します。
④ 下の表の部分にテキストを入力します
以下コードです
☆ 標準モジュールの Module1 にコピペして下さい。
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public 停止動作 As Boolean
Sub ルーレット()
Const 制限間隔 As Long = 1000
Dim 間隔 As Double
Dim 行 As Long
Dim 列 As Long
Dim 色 As Long
間隔 = 0.1
Range("B33").Value = ""
行 = 2
列 = 2
Range("B2:AO31").Interior.Color = RGB(255, 255, 255)
停止動作 = False
Do While 間隔 < 制限間隔
Cells(行, 列).Interior.Color = Int(Rnd() * 16777216)
If 停止動作 Then 間隔 = 間隔 * (1 + Rnd() * 0.3)
DoEvents
Sleep 間隔
DoEvents
Cells(行, 列).Interior.ColorIndex = xlNone
列 = 列 + 4
If 列 > 38 Then
列 = 2
行 = 行 + 3
If 行 > 29 Then 行 = 2
End If
Loop
Cells(行, 列).Interior.Color = RGB(255, 0, 0)
Range("B33:AH35").Value = Cells(((行 - 2) * 10 / 3 + (列 - 2) / 4) * 3 + 37, 6).Value
Range("AJ33").Value = "Start"
End Sub
Sub シート初期化()
Dim 行 As Long
Dim 列 As Long
Dim 番号 As Long
Application.EnableEvents = False
Sheets("ルーレット").Select
ActiveSheet.Protect UserInterfaceOnly:=True
ActiveWindow.DisplayHeadings = False
ActiveWindow.FreezePanes = False
Cells.Delete Shift:=xlUp
Cells.ColumnWidth = 0
Columns("A:AP").ColumnWidth = 0.77
Cells.RowHeight = 0
Rows("1:336").RowHeight = 7.5
Cells.Interior.Color = RGB(255, 255, 255)
Cells.VerticalAlignment = xlCenter
Cells.HorizontalAlignment = xlCenter
With Cells.Font
.Name = "BIZ UDゴシック"
.Size = 12
End With
For 行 = 2 To 29 Step 3
For 列 = 2 To 38 Step 4
番号 = 番号 + 1
With Range(Cells(行, 列), Cells(行 + 2, 列 + 3))
.MergeCells = True
.Value = 番号
End With
Next
Next
Range("B2:AO31").Borders.Weight = xlThin
With Range("B33:AH35")
.HorizontalAlignment = xlGeneral
.MergeCells = True
.Borders.Weight = xlThin
End With
Call ボタン作成("AJ33:AO35", "Start")
Range("A37").Select
ActiveWindow.FreezePanes = True
番号 = 0
For 行 = 37 To 334 Step 3
番号 = 番号 + 1
With Range(Cells(行, 2), Cells(行 + 2, 5))
.MergeCells = True
.Value = 番号
End With
With Range(Cells(行, 6), Cells(行 + 2, 41))
.HorizontalAlignment = xlGeneral
.MergeCells = True
End With
Next
With Range("B37:AO336")
.Borders.Weight = xlThin
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
Range("F37:AO336").Locked = False
Range("B33:AH35").Select
Application.EnableEvents = True
End Sub
Sub ボタン作成(範囲 As String, 文字 As String)
With Range(範囲)
With .Borders(xlEdgeLeft)
.Weight = xlMedium
.Color = RGB(255, 255, 255)
End With
With .Borders(xlEdgeTop)
.Weight = xlMedium
.Color = RGB(255, 255, 255)
End With
With .Borders(xlEdgeBottom)
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeRight)
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
.Interior.Color = RGB(192, 192, 192)
.MergeCells = True
.Value = 文字
End With
End Sub
☆ ルーレットシートモジュール にコピペして下さい。
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim 移動先 As Long
Select Case Target.Row
Case 2 To 29
Select Case Target.Column
Case 2 To 38
移動先 = ((Target.Row - 2) * 10 / 3 + (Target.Column - 2) / 4) * 3 + 37
Application.EnableEvents = False
Cells(移動先, 6).Select
Application.EnableEvents = True
Case Else
Application.EnableEvents = False
Range("B33:AH35").Select
Application.EnableEvents = True
End Select
Case 33
If Target.Column = 36 Then
Application.EnableEvents = False
Range("B33:AH35").Select
Application.EnableEvents = True
If Range("AJ33").Value = "Stop" Then
停止動作 = True
Else
Range("AJ33").Value = "Stop"
Call ルーレット
End If
End If
Case Is <= 36
Application.EnableEvents = False
Range("B33:AH35").Select
Application.EnableEvents = True
End Select
End Sub
☆ ThisWorkbook にコピペして下さい。
Option Explicit
Private Sub Workbook_Open()
Sheets("ルーレット").Select
ActiveSheet.Protect UserInterfaceOnly:=True
End Sub
No.5
- 回答日時:
No.4 の追補
「Cells(行, 列).Select」は「Select」しないと「Start」ボタンが押されたままの状態になってしまいます。
「間隔」と「間隔 * 1.2」の関係ですが「間隔」減らせば動きが速くなります。ただ「間隔 * 1.2」の結果が丸められても、元の「間隔」より大きくならないといつまでたっても止まらなくなります。
No.4
- 回答日時:
こんなのはいかがでしょうか?
「Start」ボタンを押すと移動が始まります。
「Stop」ボタンを押すと移動がゆっくりになって最後は移動先を赤にしてC14セルに値を書き込んで終了します。
☆ シートモジュールへ
Private Sub CommandButton1_Click()
Call ルーレット
End Sub
Private Sub CommandButton2_Click()
停止動作 = True
End Sub
☆ 標準モジュールへ
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public 停止動作 As Boolean
Sub ルーレット()
Const 制限間隔 As Long = 1000
Dim 間隔 As Long
Dim 行 As Long
Dim 列 As Long
Cells(14, 3).Value = ""
Range("B3:K12").Interior.ColorIndex = xlNone
間隔 = 10
停止動作 = False
Do While 間隔 < 制限間隔
行 = Int(Rnd() * 10) + 3
列 = Int(Rnd() * 10) + 2
Cells(行, 列).Select
Selection.Interior.Color = RGB(255, 255, 0)
If 停止動作 Then 間隔 = 間隔 * 1.2
DoEvents
Sleep 間隔
DoEvents
Cells(行, 列).Interior.ColorIndex = xlNone
Loop
Cells(行, 列).Interior.Color = RGB(255, 0, 0)
Cells(14, 3).Value = Cells(行, 列).Value
End Sub
ご回答ありがとうございます。かなりイメージに近い動きになりますね。
Constで予め決めておいて、それを元に調整する感じですね。
変数名も日本語で初心者にはわかりやすいです。参考にさせていただきます。
こういった発想力も身に付けたいものです。
No.3
- 回答日時:
こんにちは
>皆様のお知恵を拝借願えませんでしょうか。
ご提示のイメージで良いのでは?
敢えて言うなら・・・
実際の使用目的がわかりませんが、添付図にある「STOP」ボタンは不要ではないかなぁ?
適当な時間だけ回って勝手に止まれば良いのでしょうから。
まぁ、あっても何ら問題はありませんが、プログラム的には少しだけ複雑な作りにする必要がでてきます。
想像するところ、普通に作ると速すぎて色の点滅がよく認識できなかったりする可能性が高いので、適当にウェイトをかけてあげる必要が出ると思います。
あとは、No1様もご指摘ですが、VBAを走りっぱなしにすると画面への反映がされない可能性があるので、DoEvents()を利用してマシンに表示への反映をさせることが必要になるかも知れませんね。
No.2
- 回答日時:
>ExcelVBAで可能でしょうか?
できますよ。
でもそのための【アルゴリズム】を質問者さんが考え出すことができなければ実現することはできません。
また、VBAの記述ができなければ「代わりに作ってください」という【作業依頼】になってしまいます。
質問者さんがどこまでVBAを理解されているのか、
また、行いたいことのアルゴリズムが明確になっているか。
そういった点を「補足」しましょう。
「自力で作れるようになりたい」
ということであれば、多くの人から協力を得られると思います。
「代わりに作って」
ということであれば、暇している人が自己満足のために作ってくれるかもしれません。
・・・
なお、ここは【作業依頼】をする場所ではありませんので、
代わりに作ってくれる人が現れなくても悪く思わないようにしてください。
No.1
- 回答日時:
色付けはLOOPで行うとして、画面への反映は、DoEventsですかね。
早すぎるんでウェイトかければルーレット自体は可能でしょう。
あとは、徐々に止まる、を実装ですね。
プログラミングの醍醐味は、自分で考える、です。
もうちょっと考えてみては?
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- 画像編集・動画編集・音楽編集 PhotoScapeXで黒テキストの上に画像を重ね背景を表示する方法 1 2022/12/18 19:57
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/21 09:42
- Access(アクセス) Accessテーブルの結合で別々のテーブルのフィールドを組み合わせて値を出す方法について 2 2022/07/20 19:43
- 統計学 これは黒か赤 どちらを選んでも同じですか? 理由も教えてください(><) これからあなたは、ルーレッ 6 2022/11/21 20:28
- Excel(エクセル) VBA 特定の列に入っているテキストをコピペ 2 2023/06/14 11:24
- 簿記検定・漢字検定・秘書検定 日商簿記3級のテキストと問題集の良書 1 2023/01/31 16:40
- フリーソフト libreoffice drawのツールバーのチェックが外れてしまう 1 2022/10/04 22:02
- システム CSVファイルのマッピング処理の省力化 1 2022/11/24 00:01
- その他(プログラミング・Web制作) GASでガントチャートを作りたいです 1 2022/09/05 17:26
- その他(プログラミング・Web制作) google formsで回答者をスプレッドシートに記載する方法 1 2023/06/23 11:22
このQ&Aを見た人はこんなQ&Aも見ています
-
それもChatGPT!?と驚いた使用方法を教えてください
仕事やプライベートでも利用が浸透してきたChatGPTですが、こんなときに使うの!!?とびっくりしたり、これは画期的な有効活用だ!とうなった事例があれば教えてください!
-
歳とったな〜〜と思ったことは?
歳とったな〜〜〜、老いたな〜〜と思った具体的な瞬間はありますか?
-
もし10億円当たったら何に使いますか?
みなさんの10億円プランが知りたいです!
-
洋服何着持ってますか?
洋服を減らそうと思っているのですが、何着くらいが相場なのかわかりません。
-
【お題】斜め上を行くスキー場にありがちなこと
運営も客も一流を通り越して斜め上を行くスキー場にありがちなことを教えて下さい。
-
VBAで作れるかな?
Visual Basic(VBA)
-
VBA-指定した範囲で重複しない乱数を生成したい
その他(Microsoft Office)
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・一番好きなみそ汁の具材は?
- ・泣きながら食べたご飯の思い出
- ・「これはヤバかったな」という遅刻エピソード
- ・初めて自分の家と他人の家が違う、と意識した時
- ・いちばん失敗した人決定戦
- ・思い出すきっかけは 音楽?におい?景色?
- ・あなたなりのストレス発散方法を教えてください!
- ・もし10億円当たったら何に使いますか?
- ・何回やってもうまくいかないことは?
- ・今年はじめたいことは?
- ・あなたの人生で一番ピンチに陥った瞬間は?
- ・初めて見た映画を教えてください!
- ・今の日本に期待することはなんですか?
- ・集中するためにやっていること
- ・テレビやラジオに出たことがある人、いますか?
- ・【お題】斜め上を行くスキー場にありがちなこと
- ・人生でいちばんスベッた瞬間
- ・コーピングについて教えてください
- ・あなたの「プチ贅沢」はなんですか?
- ・コンビニでおにぎりを買うときのスタメンはどの具?
- ・おすすめの美術館・博物館、教えてください!
- ・【お題】大変な警告
- ・洋服何着持ってますか?
- ・みんなの【マイ・ベスト積読2024】を教えてください。
- ・「これいらなくない?」という慣習、教えてください
- ・今から楽しみな予定はありますか?
- ・AIツールの活用方法を教えて
- ・最強の防寒、あったか術を教えてください!
- ・歳とったな〜〜と思ったことは?
- ・モテ期を経験した方いらっしゃいますか?
- ・好きな人を振り向かせるためにしたこと
- ・スマホに会話を聞かれているな!?と思ったことありますか?
- ・それもChatGPT!?と驚いた使用方法を教えてください
- ・見学に行くとしたら【天国】と【地獄】どっち?
- ・これまでで一番「情けなかったとき」はいつですか?
- ・この人頭いいなと思ったエピソード
- ・あなたの「必」の書き順を教えてください
- ・14歳の自分に衝撃の事実を告げてください
- ・人生最悪の忘れ物
- ・あなたの習慣について教えてください!!
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excelで、あるセルの値に応じて...
-
B列の最終行までA列をオート...
-
URLのリンク切れをマクロを使っ...
-
Cellsのかっこの中はどっちが行...
-
vba 2つの条件が一致したら...
-
Worksheets メソッドは失敗しま...
-
VBAのFind関数で結合セルを検索...
-
IIF関数の使い方
-
【VBA】2つのシートの値を比較...
-
エクセル 2つの表の並べ替え
-
VBA 何かしら文字が入っていたら
-
VBAを使って検索したセルをコピ...
-
オートフィルタをマクロで作成...
-
Changeイベントでの複数セルの...
-
複数csvを横に追加していくマク...
-
VBAで、離れた複数の列に対して...
-
データグリッドビューの一番最...
-
エクセル アクティブセルから...
-
SUM関数の範囲を変数を代入して...
-
VBAで指定範囲内の空白セルを左...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
B列の最終行までA列をオート...
-
Cellsのかっこの中はどっちが行...
-
Worksheets メソッドは失敗しま...
-
Excelで、あるセルの値に応じて...
-
vba 2つの条件が一致したら...
-
IIF関数の使い方
-
VBA 何かしら文字が入っていたら
-
VBAのFind関数で結合セルを検索...
-
【VBA】2つのシートの値を比較...
-
文字列の結合を空白行まで実行
-
Changeイベントでの複数セルの...
-
URLのリンク切れをマクロを使っ...
-
VBAで指定範囲内の空白セルを左...
-
【Excel VBA】 B列に特定の文字...
-
VBAを使って検索したセルをコピ...
-
VBAで、特定の文字より後を削除...
-
エクセル 2つの表の並べ替え
-
データグリッドビューの一番最...
-
rowsとcolsの意味
-
VBAでのリスト不一致抽出について
おすすめ情報
皆様真摯なご回答ありがとうございます。
No.2様が仰る通り「作業依頼」になっていますね。
完成されたソースから1行1行見ていき、それぞれがどういう動きをしているのかを参考にしたかった次第です。
恥ずかしながらVBAの知識は誰かが作ったものを使ったことがある程度で、自力で質問内容なものを作りたいと思った次第です。現状としては空っぽの表の作成まではできましたが、セルを動かす以降のところでドツボにハマっております。表が自動で出来ただけで喜んでるレベルです。
目的はイベントの抽選大会で景品名や人名をランダムで表示させて、画面に出すというものです。
もう少し自力で挑戦してみます。