ExcelVBAでテキストルーレットを作りたい

↓こちらの質問者様からありました内容のテキストバージョンを作成したいと考えています。
https://oshiete.goo.ne.jp/qa/1530615.html

ゲームの桃太郎電鉄の次の目的駅を決めるルーレットってありますが、まさにあんな感じです。
ExcelVBAで可能でしょうか？
10×10の100マスに記載されたテキストからランダムで色の枠が動き、決定後に点滅するようなイメージです。
皆様のお知恵を拝借願えませんでしょうか。

質問者からの補足コメント

• 皆様真摯なご回答ありがとうございます。
  No.2様が仰る通り「作業依頼」になっていますね。
  完成されたソースから１行１行見ていき、それぞれがどういう動きをしているのかを参考にしたかった次第です。
  恥ずかしながらVBAの知識は誰かが作ったものを使ったことがある程度で、自力で質問内容なものを作りたいと思った次第です。現状としては空っぽの表の作成まではできましたが、セルを動かす以降のところでドツボにハマっております。表が自動で出来ただけで喜んでるレベルです。
  目的はイベントの抽選大会で景品名や人名をランダムで表示させて、画面に出すというものです。
  もう少し自力で挑戦してみます。

    補足日時：2019/12/23 17:16

No.8 ベストアンサー 回答者： GooUserラック 回答日時： 2019/12/27 05:16

テストデータを編集しやすいように別シートに置くバージョンです。

☆ インストール方法
　①「ルーレット」と「データ」シートを作成します。
　② コードをそれぞれの場所に張付けます。
　③「シート初期化」マクロを実行します。
　④「データ」シートのＡ列にテキストを入力します

☆ 使い方
・「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だけでなくプログラミングの面白さも感じました。
いま実行できる環境がないのですが、取り急ぎの御礼、ベストアンサーとさせていただきます。ありがとうございました。

お礼日時：2019/12/29 13:46

No.9 回答者： GooUserラック 回答日時： 2019/12/27 05:40

No.8 までの補足

ランダムにマスを選択する場合はテキスト全体を表示出来ないので、別枠に表示するやり方をしましたが、
多分、下図のように横は１列に縦は奇数行にして文章がスクロールするようにし真ん中が対象にした方が良い気がしました。いかがでしょうか？

No.7 回答者： GooUserラック 回答日時： 2019/12/26 16:46

No.6 の補足

使い方
・「Start」ボタンをクリックすると「Stop」ボタンに変わり、対象文がクリアされ、色が変化しながら隣のセルに移っていきます（移動はランダムではありませんが早すぎて飛んで見えると思います）
・「Stop」ボタンをクリックすると移動速度がだんだん遅くなって（遅くなり方がランダムです）止まると「Start」ボタンに戻って対象文が表示されます。
・ 上部の数字部分をクリックすると、その数字の文章のセルが選択され見る事が出来ます。（ルーレットが動いていても可能です）
・ 文章データはリンクの方が良いかもしれません

No.6 回答者： GooUserラック 回答日時： 2019/12/26 16:22

お気に召さないようなので、元のリンク先を参考に作り直してみました。

①「ルーレット」というシートを作成します。
② コードをそれぞれの場所に張付けます。
③「シート初期化」マクロを実行します。
④ 下の表の部分にテキストを入力します

以下コードです

☆ 標準モジュールの 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 回答者： GooUserラック 回答日時： 2019/12/24 14:56

No.4 の追補

「Cells(行, 列).Select」は「Select」しないと「Start」ボタンが押されたままの状態になってしまいます。
「間隔」と「間隔 * 1.2」の関係ですが「間隔」減らせば動きが速くなります。ただ「間隔 * 1.2」の結果が丸められても、元の「間隔」より大きくならないといつまでたっても止まらなくなります。

No.4 回答者： GooUserラック 回答日時： 2019/12/24 14:46

こんなのはいかがでしょうか？

「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で予め決めておいて、それを元に調整する感じですね。
変数名も日本語で初心者にはわかりやすいです。参考にさせていただきます。
こういった発想力も身に付けたいものです。

お礼日時：2019/12/25 13:06

No.3 回答者： fujillin 回答日時： 2019/12/23 13:46

こんにちは

＞皆様のお知恵を拝借願えませんでしょうか。
ご提示のイメージで良いのでは？

敢えて言うなら・・・
実際の使用目的がわかりませんが、添付図にある「ＳＴＯＰ」ボタンは不要ではないかなぁ？
適当な時間だけ回って勝手に止まれば良いのでしょうから。
まぁ、あっても何ら問題はありませんが、プログラム的には少しだけ複雑な作りにする必要がでてきます。

想像するところ、普通に作ると速すぎて色の点滅がよく認識できなかったりする可能性が高いので、適当にウェイトをかけてあげる必要が出ると思います。
あとは、No1様もご指摘ですが、VBAを走りっぱなしにすると画面への反映がされない可能性があるので、DoEvents()を利用してマシンに表示への反映をさせることが必要になるかも知れませんね。

No.2 回答者： 銀鱗 回答日時： 2019/12/23 13:16

＞ExcelVBAで可能でしょうか？

できますよ。
でもそのための【アルゴリズム】を質問者さんが考え出すことができなければ実現することはできません。
また、VBAの記述ができなければ「代わりに作ってください」という【作業依頼】になってしまいます。

質問者さんがどこまでVBAを理解されているのか、
また、行いたいことのアルゴリズムが明確になっているか。
そういった点を「補足」しましょう。

「自力で作れるようになりたい」
ということであれば、多くの人から協力を得られると思います。
「代わりに作って」
ということであれば、暇している人が自己満足のために作ってくれるかもしれません。

・・・
なお、ここは【作業依頼】をする場所ではありませんので、
代わりに作ってくれる人が現れなくても悪く思わないようにしてください。

No.1 回答者： くんこば 回答日時： 2019/12/23 13:15

色付けはLOOPで行うとして、画面への反映は、DoEventsですかね。

早すぎるんでウェイトかければルーレット自体は可能でしょう。

あとは、徐々に止まる、を実装ですね。

プログラミングの醍醐味は、自分で考える、です。
もうちょっと考えてみては？