『がらがらを作りたいのですが・・・』（ラッキー男）
はじめまして。
年末の抽選くじを用意するように指示された不運な事務員です。
オートシェイプでそれらしく絵を描きました。赤玉、青玉、黄玉、緑玉、黒玉と。
この玉をぐるぐると動かして一つだけ飛び出すように動かす方法を教えてください。
名案、代案、紹介等何でも良いので教えてください。
よろしくお願いします。
Excel2003、WindowsXP
----
 おもしろそうなので。
 シェープの名前はなんでもいいけど、コードでは以下にしている。

 かご　"basket"
 この、かごの中にボールを。"ovlRed","ovlBlue","ovlBlack","ovlYellow","ovlGreen"
 これとは別に、当選ボールが入る枠を、【塗りつぶしなし】で、"winner"

 ちょっと手を抜いていて、がらがら中、ボールがかごを少し飛び出してしまうけど。

 Sub がらがら()
    Dim v(1 To 5) As Shape  '玉の数分
    Dim pos(1 To 5, 1 To 2) As Double '元の位置
    Dim sp As Variant
    Dim z As Long
    Dim x1 As Long, x2 As Long
    Dim y1 As Long, y2 As Long
    Dim l As Long, t As Long
    Dim winner As Shape
    
    With ActiveSheet
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        For Each sp In v
            z = z + 1
            pos(z, 1) = sp.Left
            pos(z, 2) = sp.Top
        Next
        With .Shapes("basket")
            x1 = .Left
            x2 = x1 + .Width
            y1 = .Top
            y2 = y1 + .Height
        End With
        Set winner = .Shapes("Winner")
    End With
    
    For z = 1 To 50    'ガラガラ数
            For Each sp In v
            'がらがら実行
                With sp
                    l = Int((x2 - x1 + 1) * Rnd + x1)
                    t = Int((y2 - y1 + 1) * Rnd + y1)
                    .Left = l
                    .Top = t
                End With
            Next
        Sleep 10
        DoEvents
    Next
    z = 0
    For Each sp In v
        z = z + 1
        sp.Left = pos(z, 1)
        sp.Top = pos(z, 2)
    Next
    
    z = Int((UBound(v)) * Rnd + 1)  'Winner
    With v(z)
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
        
    End With
    
 End Sub

 (ぶらっと)
----
↑　１行、アップ忘れ。　この標準モジュールの最初に

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

 (ぶらっと)
----
 なお、↑は、ガラガラ回数を、コードで規定しているけど、たとえば　何かのキー（シフトキーとか）
 を押すまでは、がらがら回し、キーをおしたときに止めるということもできる。

 コードで規定するとしてアップしたコードの 50回は、すくなすぎるかも。
 200回ぐらいのほうが、回しているという感じがでるかな？

 (ぶらっと)
----
くじならなんでもよいなら、三角くじがあります
http://download.seesaa.jp/contents/win/ent/e_other/14332/

 これどこかでリンクされていたのを試しに使ってみただけですが、色付ではないですが、
 同じ事は出来ると思いますよ

 ichinose

----
 がらがら回数は特定せず、シフトキーを押したら終了させるコード。
 なお、アップ済みのものは【インチキ】している。
 （がらがらの状況には関係なく、最後に当然ボールを決めている）

 以下では、あわせて、止めたときに一番右にあったボールを当選にしている。



 Sub がらがら2()
    Dim v(1 To 5) As Shape  '玉の数分
    Dim pos(1 To 5, 1 To 2) As Double '元の位置
    Dim sp As Variant
    Dim z As Long
    Dim x1 As Long, x2 As Long
    Dim y1 As Long, y2 As Long
    Dim l As Long, t As Long
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    
    With ActiveSheet
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        For Each sp In v
            z = z + 1
            pos(z, 1) = sp.Left
            pos(z, 2) = sp.Top
        Next
        With .Shapes("basket")
            x1 = .Left
            x2 = x1 + .Width
            y1 = .Top
            y2 = y1 + .Height
        End With
        Set winner = .Shapes("Winner")
    End With
    
    Do
    If GetAsyncKeyState(vbKeyShift) <> 0 Then Exit Do 'シフトキーがおされたら終了
            For Each sp In v
            'がらがら実行
                With sp
                    l = Int((x2 - x1 + 1) * Rnd + x1)
                    t = Int((y2 - y1 + 1) * Rnd + y1)
                    .Left = l
                    .Top = t
                End With
            Next
        Sleep 10
        DoEvents
    Loop
    
    z = 0
    For Each sp In v
        If sp.Left > maxL Then
            maxL = sp.Left
            Set winBall = sp
        End If
        z = z + 1
        sp.Left = pos(z, 1)
        sp.Top = pos(z, 2)
    Next
    
    With winBall
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
        
    End With
    
 End Sub

 ● なお、モジュールの先頭に以下も追加。

 Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

 (ぶらっと)
----
 連投失礼。悪乗りして、がらがらする時に、かごもまわした。

 Sub がらがら3()
    Dim v(1 To 5) As Shape  '玉の数分
    Dim pos(1 To 5, 1 To 2) As Double '元の位置
    Dim sp As Variant
    Dim z As Long
    Dim x1 As Long, x2 As Long
    Dim y1 As Long, y2 As Long
    Dim l As Long, t As Long
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bRotation As Long
    
    With ActiveSheet
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        For Each sp In v
            z = z + 1
            pos(z, 1) = sp.Left
            pos(z, 2) = sp.Top
        Next
        Set basket = .Shapes("basket")
        With basket
            x1 = .Left
            x2 = x1 + .Width
            y1 = .Top
            y2 = y1 + .Height
        End With
        Set winner = .Shapes("Winner")
    End With
    
    Do
    If GetAsyncKeyState(vbKeyShift) <> 0 Then Exit Do 'シフトキーがおされたら終了
            For Each sp In v
            'がらがら実行
                With sp
                    l = Int((x2 - x1 + 1) * Rnd + x1)
                    t = Int((y2 - y1 + 1) * Rnd + y1)
                    .Left = l
                    .Top = t
                End With
                bRotation = bRotation + 1
                basket.Rotation = bRotation
            Next
        Sleep 10
        DoEvents
    Loop
    
    z = 0
    For Each sp In v
        If sp.Left > maxL Then
            maxL = sp.Left
            Set winBall = sp
        End If
        z = z + 1
        sp.Left = pos(z, 1)
        sp.Top = pos(z, 2)
    Next
    
    basket.Rotation = 0
    
    With winBall
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
        
    End With
    
 End Sub

 (ぶらっと)
----
 横から失礼します。
 がらがら、作らせていただきました。
 楽しくて何度も回してしまっています（笑）
 すごいです！

 ちなみに、シフトキーを押してwinBallを決めた後、
 再びがらがらする前に、winBallをbasketに戻して再スタートするには
 どうすればいいのでしょうか？

（茶々）


----
(ぶらっと)コードありがとうございます。
遊んでいる間にあっという間に時間が過ぎてしまいました。
やっていて（茶々）さんが指摘している事と玉が回るのが転がっているかんじがしないなぁと思いました。
八角形のバスケットの中で転がるように回れば完璧なのに・・自分では出来もしないのに勝手な想像をしてしまいます。申し訳ないです。
----
 >八角形のバスケットの中で転がるように回れば完璧なのに・

 確かにねぇ・・　ボールがバスケットの壁にぶつかって、跳ね返って別のところにとんでいくという効果は
[[20111130100821]]　『図形を浮遊させる』（俊介）
 ここの、ｍｏｍｏさんがアップしたコードのロジックを組み込めばいいと思うけど、かごが回るということに
 対応させるのも含めて、かなりやっかいかもね。
 おもしろそうなので、勉強をかねてやってみるけど、さて・・・
 完成に１年ぐらいかかりそう。

 >再びがらがらする前に、winBallをbasketに戻して再スタートするには

 これは、なんとかなりそうなのでやってみる。少し時間くださいな。

 (ぶらっと)
----
 かごの中の玉の動きは、基本的にかえていないけど、かごの中から飛び出さないようにしたので
 なんとなく、かごの中で、ゆさぶられているような、シャッフルされているようなイメージに近くなったのではと思うけど
 どうだろうか。

 実行すると最初に、各玉が、どこにあろうと、かごの真ん中あたりにランダムにほうりこんで開始するので
 winBallとして、飛びでているものがあたとしても、そのまま実行可能。

 Option Explicit

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

 Sub がらがら4()
    Const adjustX As Long = 50
    Dim v(1 To 5) As Shape  '玉の数分
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bRotation As Long
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    
    With ActiveSheet
        Set basket = .Shapes("basket")
        With basket
            bTop = .Top + adjustX
            bBottom = .Top + .Height - adjustX
            bLeft = .Left + adjustX
            bRight = .Left + .Width - adjustX
        End With
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        For Each sp In v
            sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
            sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
        Next
        
        Set winner = .Shapes("Winner")
    End With
    
    Do
    If GetAsyncKeyState(vbKeyShift) <> 0 Then Exit Do 'シフトキーがおされたら終了
            For Each sp In v
            'がらがら実行
                sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
                sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
                bRotation = bRotation + 1
                basket.Rotation = bRotation
            Next
        Sleep 10
        DoEvents
    Loop
    
    For Each sp In v
        If sp.Left > maxL Then
            maxL = sp.Left
            Set winBall = sp
        End If
    Next
    
    basket.Rotation = 0
    
    With winBall
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
    End With
    
 End Sub

 (ぶらっと)
----
 ↑とかえてはいないけど、最後に winBallが少しフラッシュする。
 お好みならこちらを。

 Option Explicit

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

 Sub がらがら5()
    Const adjustX As Long = 50
    Dim v(1 To 5) As Shape  '玉の数分
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bRotation As Long
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim z As Long
    
    With ActiveSheet
        Set basket = .Shapes("basket")
        With basket
            bTop = .Top + adjustX
            bBottom = .Top + .Height - adjustX
            bLeft = .Left + adjustX
            bRight = .Left + .Width - adjustX
        End With
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        For Each sp In v
            sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
            sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
        Next
        
        Set winner = .Shapes("Winner")
    End With
    
    Do
    If GetAsyncKeyState(vbKeyShift) <> 0 Then Exit Do 'シフトキーがおされたら終了
            For Each sp In v
            'がらがら実行
                sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
                sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
                bRotation = bRotation + 1
                basket.Rotation = bRotation
            Next
        Sleep 10
        DoEvents
    Loop
    
    For Each sp In v
        If sp.Left > maxL Then
            maxL = sp.Left
            Set winBall = sp
        End If
    Next
    
    basket.Rotation = 0
    
    With winBall
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
        For z = 1 To 100
            .Visible = Not .Visible
            DoEvents
            Sleep 10
        Next
    End With
    
 End Sub

 (ぶらっと)
----
 またまた横から失礼します。

（ぶらっと）さん、スゴいですっ！
 ありがとうございました。
 楽しくて、また何度も回してしまいました。

 私は最初のがらがらの動きのほうが好きなので、
 「再びがらがらする前に、winBallをbasketに戻して再スタートするには」の記述は
 どこでしょうか？
 ↑自分で組み合わせてみようと思ったのですが、よくわからなくて…

 何度もすみません。よろしくお願いします。

 （茶々）


----
(ぶらっと)さん
ラッキー男です。
作って頂き感謝しています。これで準備万端、後は景品を買うだけです。
後一つ疑問が・・イイですか？
basket.Rotation = 0　でカゴを回転させていると思うのですが０を１０００に変えてもあまり早くなりません。
こんなものでしょうか？

----
 To 茶々さん

 >「再びがらがらする前に、winBallをbasketに戻して再スタートするには」の記述は どこでしょうか？

 最初のほうにある

        For Each sp In v
            sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
            sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
        Next

 ここで、５つのシェープに対して、ランダムな縦位置、横位置を与えている。

 To ラッキー男さん

 >basket.Rotation = 0　でカゴを回転させていると思うのですが０を１０００に変えてもあまり早くなりません。 

 いやいや、これは、最後にとまった時に、かごの角度を 0 つまり回転なしの状態に戻しているところ。
 回転は、

                bRotation = bRotation + 1
                basket.Rotation = bRotation

 ここでやっている。　シェープ.Rotation が、回転角度。ループの中で 1度ずつアップしている。
 これを + 2 とか + 3 とかにすれば、回る速度が速くなる。

 (ぶらっと)
----
 （ぶらっと）さん、ありがとうございました。

 （ラッキー男）さん、横から失礼しました！

（茶々）
----
 上のほうでアップした　がらがら5　は、アイデア倒れというか、フラッシュさせても
 だから、どうなんだ？　という印象だったね。

 動きを早くしたいというラッキー男さんのコメントで、ふと思いついて。
 以下は（もう、これで最後にするけど）終わりのフラッシュはやめて 新しく

 ・ゆ〜っくり回転。ボールもかごの下のほうで動くだけ。（レベル１）
 ・回転中に　↑矢印キーでレベル２に移行。回転が速くなり、ボールの動きも
 　かごの中全体になる。
 ・↓矢印キーでレベル１にもどる。回転中、↑キー、↓キーを何度でもおすことができる。

 Option Explicit

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

 Sub がらがら6()
    Dim v(1 To 5) As Shape  '玉の数分
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim winLoop As Long
    Dim winSleep As Long
    Dim z As Long
    Dim hWnd As Long
    Dim i As Long
    Dim moveUp As Boolean
    Dim rtnS As Long
    Dim rtnZ As Long
    Dim rtnU As Long
    Dim rtnD As Long
    Dim udChange As Boolean
    Dim addRote As Long
    
    With ActiveSheet
        Set basket = .Shapes("basket")
        
        bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        
        Set v(1) = .Shapes("ovlBlue")
        Set v(2) = .Shapes("ovlred")
        Set v(3) = .Shapes("ovlblack")
        Set v(4) = .Shapes("ovlyellow")
        Set v(5) = .Shapes("ovlgreen")
        
        BallSet v, bLeft, bRight, bTop, bBottom
        Set winner = .Shapes("Winner")
    End With
 
    Do
        rtnS = GetAsyncKeyState(vbKeyShift)
        If rtnS <> 0 Then Exit Do      'シフトキーがおされたら終了
        rtnD = GetAsyncKeyState(vbKeyDown)
        rtnU = GetAsyncKeyState(vbKeyUp)
        udChange = False
        If rtnU And &H80000000 <> 0 Then
            moveUp = True
            udChange = True
        ElseIf rtnD And &H80000000 <> 0 Then
            moveUp = False
            udChange = True
        End If
        
        If udChange Then
            bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        Else
            'がらがら実行
            addRote = 100
            If moveUp Then
                addRote = 4
            End If
            For Each sp In v
                BallSet v, bLeft, bRight, bTop, bBottom
                basket.Rotation = basket.Rotation + addRote
                If Not moveUp Then Sleep 10
            Next
        End If
        Sleep 10
        DoEvents
    Loop

    For Each sp In v
        If sp.Left > maxL Then
            maxL = sp.Left
            Set winBall = sp
        End If
    Next
 
    basket.Rotation = 0
 
    With winBall
        .Left = winner.Left + winner.Width / 2 - .Width / 2
        .Top = winner.Top + winner.Height / 2 - .Height / 2
    End With
    
 End Sub

 Private Sub BallSet(v As Variant, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double)
    Dim sp As Variant
    For Each sp In v
        sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
        sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
    Next
 End Sub
 
 Private Sub bRangeSet(moveUp As Boolean, basket As Shape, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double)
        With basket
            If moveUp Then
                bTop = .Top + .Height / 4
            Else
                bTop = .Top + .Height / 4 * 3
            End If
            bBottom = .Top + .Height - adjustX
            bLeft = .Left + adjustX
            bRight = .Left + .Width - adjustX
        End With

 End Sub

 (ぶらっと)
----
ぶらっとさん、こんにちはラッキー男です。
休日ですが見られているかなぁー
チョット長く回していると（１８秒ほど）実行時エラー -2147024809(80070057)
指定された値は境界を超えています。
basket.Rotation = bRotation 此処で留まります。
最大３０秒は回したいのですが、対応策がありましたら教えてください。
(ラッキー男)
----
 >チョット長く回していると（１８秒ほど）実行時エラー -2147024809(80070057) 
 >指定された値は境界を超えています。 

 こちらでも、まったく別のアプリだけど、同じような制御を取り入れたもので、同じエラーが
 発生するバグがあって、「限界値を超えないような」対応を組み込んだ。

 がらがらの、どこに、どう組み込まばいいか、ちょっとさぐってみるので、しばしお待ちを。

 ところで、使っているのが、どのバージョン？
 最後にアップした、動きのレベルが２段階のもの？

 (ぶらっと)
----
 こちらでは、今、3分回したけどエラーにはならない。ただし Win7 + 2010
 以下のように　★のコードを追加したらどうなるかな？

    bRotation = bRotation Mod 360    '★　追加
    basket.Rotation = bRotation  

 (ぶらっと)  　　　　
----
ぶらっと、見ていてくれてありがとうございます。
ホント、ラッキーな男です。
使わせていただいてるのは、がらがら5()です。
最後のはイイのですが着色したら重くて回らないので諦めました。
(ラッキー男)

----
ぶらっとさん、衝突してしまいました。
こちらは、WinXpで2003の環境です。
いま、動かしました。凄いの一言です。本物そっくり！！
もう一ついいですか！玉が落ちる Set winner = .Shapes("Winner")
なのですが、リアルにと思い太さのポイントを大きくしたら玉が埋まってしまいます。
これはどこを直せば良くなるのでしょうか？
(ラッキー男)
----
 まず、今後、がらがら5　をベースにするか　がらがら6　をベースにするか確認お願い。
 先ほど連絡した　basket.Rotation = bRotation  も、がらがら6なら、少しコードが異なるので。
 (対処の考え方は同じだけど）

 >太さのポイントを大きくしたら玉が埋まってしまいます

 これは具体的にはどういうことかな？

 ・最後に当選ボールを入れる箱のことを言っている？
 　で、この枠を太くしたら、ボールの端っこが枠の下に埋もれてしまう？

 　★もし、そういうことなら、枠の上に表示されるように１行コードを追加する。

 ・それとも、がらがらのかご？　

 　★もし、そういうことなら、Private Const adjustX As Long = 50　の数字を少し大きくすると
 　　その分、動きが内側に狭められる。

 どちらのことか連絡お願いね。

 余談）あれから、こちらでは　がらがら6　で、当選したボールが Winner に納められる際に
 　　　ポーンと、弧を描いて飛び込むようにしたバージョン、がらがら7　にしている。
 　　　また、このバージョンは、ボールが何個でもＯＫ。（名前が ovl●●　のものをすべて対象にしている）
 　　　ご希望ならコードをアップする。

 　　　それと、今ふと思ったんだけど、通常、このゲームは、たとえば赤玉がでれば、その玉は勝ち抜け。
 　　　次に回すときは、赤玉は除くよね。そういうこともオプションで可能にした、がらがら8 も作ってみようかなと
　     思っている。

 (ぶらっと)
----
ぶらっとさん、こんばんは。
わたしは、がらがら5が気に入り準備しています。
はい、最後に当選ボールを入れる箱のことを言っている？
 　で、この枠を太くしたら、ボールの端っこが枠の下に埋もれてしまう？
そうです。

わたしも、動かしていて玉の数を増やすには面倒でも同じように書かないと行け無いなあと思っていました。
それと、玉が減らなくなったのがチョットと思っています。がらがら１〜３までは減りましたから・・・
でも玉が多すぎると低スペックなパソコンでは無理なのかと思ったりしています。
(ラッキー男) 

----
 一度、以下で総入れ替えして、がらがら8　を試してみてくれないかな？
 イメージ的に、今いちで、がらがら5　のベースにしたいということなら、がらがら5に、今回の要件を
 追加するので。

 Option Explicit

 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
 Private Const adjustX As Long = 50     'バスケット領域内の"クライアント領域"の調整値
 '以下は状況に応じて数値を変更
 Private Const addRote1 As Long = 1     'レベル1 の各ボール位置移動後の回転角度単位
 Private Const addRote2 As Long = 4     'レベル2 の各ボール位置移動後の回転角度単位
 Private Const sleepA1 As Long = 10     'レベル1 の各ボール位置移動後のSleepミリ秒
 Private Const sleepA2 As Long = 0      'レベル2 の各ボール位置移動後のSleepミリ秒
 Private Const sleepB1 As Long = 20     'レベル1 の全ボール位置移動後のSleepミリ秒
 Private Const sleepB2 As Long = 5      'レベル2 の全ボール位置移動後のSleepミリ秒
 
 Sub がらがら8()
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim winLoop As Long
    Dim winSleep As Long
    Dim z As Long
    Dim hWnd As Long
    Dim i As Long
    Dim moveUp As Boolean
    Dim rtnS As Long
    Dim rtnZ As Long
    Dim rtnU As Long
    Dim rtnD As Long
    Dim udChange As Boolean
    Dim addRote As Long
    Dim ballCnt As Long
    Dim sleepA As Long
    Dim sleepB As Long
    Dim BallOK As Boolean
    
    With ActiveSheet
        
        If Not makeBall(v) Then
            MsgBox "回すボールがありませんよ"
        End If
        
        Set basket = .Shapes("basket")
        
        bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        
        BallSet v, bLeft, bRight, bTop, bBottom, basket
        Set winner = .Shapes("Winner")
    End With
 
    Do
        rtnS = GetAsyncKeyState(vbKeyShift)
        If rtnS <> 0 Then Exit Do      'シフトキーがおされたら終了
        rtnD = GetAsyncKeyState(vbKeyDown)
        rtnU = GetAsyncKeyState(vbKeyUp)
        udChange = False
        If rtnU And &H80000000 <> 0 Then
            moveUp = True
            udChange = True
        ElseIf rtnD And &H80000000 <> 0 Then
            moveUp = False
            udChange = True
        End If
        
        If udChange Then
            bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        Else
            'がらがら実行
            addRote = addRote1
            sleepA = sleepA1
            sleepB = sleepB1
            If moveUp Then
                addRote = addRote2
                sleepA = sleepA2
                sleepB = sleepB2
            End If
            For Each sp In v
                BallSet v, bLeft, bRight, bTop, bBottom, basket
                basket.Rotation = (basket.Rotation + addRote) Mod 360
                Sleep sleepA
            Next
        End If
        Sleep sleepB
        DoEvents
    Loop

    For Each sp In v
        If sp.Visible Then
            If sp.Left > maxL Then
                maxL = sp.Left
                Set winBall = sp
            End If
        End If
    Next
 
    basket.Rotation = 0
 
    Call Win(winBall, winner.Left + winner.Width / 2, winner.Top + winner.Height / 2)
    winner.ZOrder msoSendToBack
    
    If MsgBox("おめでとうございます。このボールを勝ち抜けにしますか？", vbYesNo) = vbYes Then winBall.Visible = False
    
 End Sub

 Private Sub BallSet(v As Variant, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double, basket As Shape)
    Dim sp As Variant
    For Each sp In v
        sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
        sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
    Next
    basket.ZOrder msoSendToBack
 End Sub
 
 Private Sub bRangeSet(moveUp As Boolean, basket As Shape, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double)
        With basket
            If moveUp Then
                bTop = .Top + .Height / 4
            Else
                bTop = .Top + .Height / 4 * 2.5
            End If
            bBottom = .Top + .Height - adjustX
            bLeft = .Left + adjustX
            bRight = .Left + .Width - adjustX
        End With

 End Sub

 Private Sub Win(myBall As Shape, p As Double, q As Double)
    
    Dim x As Double, y As Double
    Dim w As Double, h As Double
    Dim a As Double
    Const grids As Long = 50
    Dim graduation As Double
    
    Dim z As Long
    
    
    With myBall
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        w = .Width
        h = .Height
    End With
    
    graduation = (p - x) / grids
    
    a = (y - q) / (x - p) ^ 2
    
    For z = 1 To grids
    
        If z = grids Then
            x = p
            y = q
        Else
            x = x + graduation
            y = a * (x - p) ^ 2 + q
        End If
        
        myBall.Left = x - w / 2
        myBall.Top = y - h / 2
        
        Sleep 10
        DoEvents
        DoEvents
        
    Next
    
 End Sub

 Private Function makeBall(v() As Shape) As Boolean
    Dim sp As Shape
    Dim vFlag As Boolean
    
    With ActiveSheet
         For Each sp In .Shapes
            If sp.Name Like "ovl*" And sp.Visible Then
                If vFlag Then
                    ReDim Preserve v(1 To UBound(v) + 1)
                Else
                    ReDim v(1 To 1)
                    vFlag = True
                End If
                Set v(UBound(v)) = sp
                makeBall = True
            End If
        Next
    End With
    
 End Function
 
 Sub Reset8()
    Dim sp As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim basket As Shape
    
    With ActiveSheet
        .DrawingObjects.Visible = True
        makeBall v
        Set basket = .Shapes("basket")
        bRangeSet False, basket, bLeft, bRight, bTop, bBottom
        BallSet v, bLeft, bRight, bTop, bBottom, basket
    End With
    
 End Sub

 (ぶらっと)
----
 追伸

 ボールが対象外になっていってがらがらの中のボールが少なくなっていき、最後はなくなってしまうね。
 で、もう一度、ボールをがらがらに入れなおすのが Reset8 。
 このReset8 は、何個か消えた後に途中で実行してもOK。

 (ぶらっと)
----
ぶらっとさん。コードありがとうございます。
凄く長いのに驚いています。
「回すボールがありませんよ」で止まりそれでも「実行中」で実行時エラー91
オブジェクト変数またはWithブロック変数が設定されていません。
 x = .Left + .Width / 2　で止まっています。

(ラッキー男)
----
 え？　ボール名は ovl で始まっているんだよね？

 メッセージの後、終わらないでエラーになってしまったのは、コードアップ時のミス。（ごめん）

 MsgBox "回すボールがありませんよ"

 このあとに

 Exit Sub

 これを入れて。

 ただ、なぜ、そう見なされたかが・・・・・？？
 ちゃんと、名前が　ovl で始まり、表示されているボールはあるんだよねぇ・・・・

 (ぶらっと)
----
ぶらっとさん、おはようございます。
昨日はお休みの処ありがとうございました。
ご指摘頂いた箇所を直し動きました、ヤッターです。
でも、、、 
     回転は、   bRotation = bRotation + 1
                basket.Rotation = bRotation
ココが無くなりカゴの回転が非常に遅くなり今一つ・・・です。
無理ばかり言いますがカゴの回転も速くならないでしょうか？

(ラッキー男)
----
 >ココが無くなりカゴの回転が非常に遅くなり今一つ・・・です。
 >無理ばかり言いますがカゴの回転も速くならないでしょうか？


 従来の

 bRotation = bRotation + 1
 basket.Rotation = bRotation

 これは、がらがら8 では

 basket.Rotation = (basket.Rotation + addRote) Mod 360

 で、この増分のaddRote は　レベルによって 1 ないしは 4 になっている。
 この 1 や 4 は、

 '以下は状況に応じて数値を変更
 Private Const addRote1 As Long = 1     'レベル1 の各ボール位置移動後の回転角度単位
 Private Const addRote2 As Long = 4     'レベル2 の各ボール位置移動後の回転角度単位
 Private Const sleepA1 As Long = 10     'レベル1 の各ボール位置移動後のSleepミリ秒
 Private Const sleepA2 As Long = 0      'レベル2 の各ボール位置移動後のSleepミリ秒
 Private Const sleepB1 As Long = 20     'レベル1 の全ボール位置移動後のSleepミリ秒
 Private Const sleepB2 As Long = 5      'レベル2 の全ボール位置移動後のSleepミリ秒

 こういったところで規定しているので、これら数字をいじくると、動きに変化がでると思う。
 ただ、こちらで、ボールを１０個ぐらいにして動かしているんだけど、遅いかなぁ？

 念のため、最初に、がらがら6　をアップしたときに、矢印キー（↑　や　↓）によるレベルの変化の
 説明をしていて、このがらがら8　は、がらがら6の改訂版の、そのまた改訂版。
 そのときの説明にもあるけど、最初は、すごく、ゆっくり動く。↑キーをおすとレベル２になって
 早く回る。レベル２からレベル１に戻すこともできる。シフトキーは、どのレベルのときにでも
 おすことはできる。

 で、レベル２でも遅いということ？

 (ぶらっと)
----
 がらがら8　の確認ももらっていない状況で、混乱するかもしれないけど参考として、こちらの最新版
 がらがら9 と Reset9 もアップしておくね。
 がらがら8　では、当選ボールが当選かごに弧を描いて放り込まれるところまで組み込んだけど
 がらがら9は、それに加えて、

 ・勝ち抜け に対して No を選んだときに、ボールをがらがらに、弧を描いて戻す。
 ・勝ち抜け　に対して Yes を選んで消えたボールを、Reset9 でがらがらに戻す際に、１つずつ弧を描いて戻す。

 Option Explicit

 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
 Private Const adjustX As Long = 50     'バスケット領域内の"クライアント領域"の調整値
 '以下は状況に応じて数値を変更
 Private Const addRote1 As Long = 1     'レベル1 の各ボール位置移動後の回転角度単位
 Private Const addRote2 As Long = 4     'レベル2 の各ボール位置移動後の回転角度単位
 Private Const sleepA1 As Long = 10     'レベル1 の各ボール位置移動後のSleepミリ秒
 Private Const sleepA2 As Long = 0      'レベル2 の各ボール位置移動後のSleepミリ秒
 Private Const sleepB1 As Long = 20     'レベル1 の全ボール位置移動後のSleepミリ秒
 Private Const sleepB2 As Long = 5      'レベル2 の全ボール位置移動後のSleepミリ秒
 
 Sub がらがら9()
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim winLoop As Long
    Dim winSleep As Long
    Dim z As Long
    Dim hWnd As Long
    Dim i As Long
    Dim moveUp As Boolean
    Dim rtnS As Long
    Dim rtnZ As Long
    Dim rtnU As Long
    Dim rtnD As Long
    Dim udChange As Boolean
    Dim addRote As Long
    Dim ballCnt As Long
    Dim sleepA As Long
    Dim sleepB As Long
    Dim BallOK As Boolean
    Dim svX As Double
    Dim svY As Double
    
    With ActiveSheet
        
        If Not makeBall(v) Then
            MsgBox "回すボールがありませんよ"
            Exit Sub
        End If
        
        Set basket = .Shapes("basket")
        
        bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        
        BallSet v, bLeft, bRight, bTop, bBottom, basket
        Set winner = .Shapes("Winner")
    End With
 
    Do
        rtnS = GetAsyncKeyState(vbKeyShift)
        If rtnS <> 0 Then Exit Do      'シフトキーがおされたら終了
        rtnD = GetAsyncKeyState(vbKeyDown)
        rtnU = GetAsyncKeyState(vbKeyUp)
        udChange = False
        If rtnU And &H80000000 <> 0 Then
            moveUp = True
            udChange = True
        ElseIf rtnD And &H80000000 <> 0 Then
            moveUp = False
            udChange = True
        End If
        
        If udChange Then
            bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        Else
            'がらがら実行
            addRote = addRote1
            sleepA = sleepA1
            sleepB = sleepB1
            If moveUp Then
                addRote = addRote2
                sleepA = sleepA2
                sleepB = sleepB2
            End If
            For Each sp In v
                BallSet v, bLeft, bRight, bTop, bBottom, basket
                basket.Rotation = (basket.Rotation + addRote) Mod 360
                Sleep sleepA
            Next
        End If
        Sleep sleepB
        DoEvents
    Loop

    For Each sp In v
        If sp.Visible Then
            If sp.Left > maxL Then
                maxL = sp.Left
                Set winBall = sp
            End If
        End If
    Next
 
    basket.Rotation = 0
 
    With winBall
        svX = .Left + .Width / 2
        svY = .Top + .Height / 2
    End With
    
    Call Parabola(winBall, winner.Left + winner.Width / 2, winner.Top + winner.Height / 2)
    winner.ZOrder msoSendToBack
    
    If MsgBox("おめでとうございます。このボールを勝ち抜けにしますか？", vbYesNo) = vbYes Then
        winBall.Visible = False
    Else
        Call Parabola(winBall, svX, svY)
    End If
    
 End Sub

 Private Sub BallSet(v As Variant, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double, basket As Shape)
    Dim sp As Variant
    For Each sp In v
        sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
        sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
    Next
    basket.ZOrder msoSendToBack
 End Sub
 
 Private Sub bRangeSet(moveUp As Boolean, basket As Shape, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double)
        With basket
            If moveUp Then
                bTop = .Top + .Height / 4
            Else
                bTop = .Top + .Height / 4 * 2.5
            End If
            bBottom = .Top + .Height - adjustX
            bLeft = .Left + adjustX
            bRight = .Left + .Width - adjustX
        End With

 End Sub

 Private Sub Parabola(myBall As Variant, p As Double, q As Double)
    
    Dim x As Double, y As Double
    Dim w As Double, h As Double
    Dim a As Double
    Const grids As Long = 50
    Dim graduation As Double
    
    Dim z As Long
    
    
    With myBall
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        w = .Width
        h = .Height
    End With
    
    graduation = (p - x) / grids
    
    a = (y - q) / (x - p) ^ 2
    
    For z = 1 To grids
    
        If z = grids Then
            x = p
            y = q
        Else
            x = x + graduation
            y = a * (x - p) ^ 2 + q
        End If
        
        myBall.Left = x - w / 2
        myBall.Top = y - h / 2
        
        Sleep 10
        DoEvents
        DoEvents
        
    Next
    
 End Sub

 Private Function makeBall(v() As Shape) As Boolean
    Dim sp As Shape
    Dim vFlag As Boolean
    
    With ActiveSheet
         For Each sp In .Shapes
            If sp.Name Like "ovl*" And sp.Visible Then
                If vFlag Then
                    ReDim Preserve v(1 To UBound(v) + 1)
                Else
                    ReDim v(1 To 1)
                    vFlag = True
                End If
                Set v(UBound(v)) = sp
                makeBall = True
            End If
        Next
    End With
    
 End Function
 
 Sub Reset9()
    Dim sp As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim basket As Shape
    
    With ActiveSheet
    
        Set basket = .Shapes("basket")
        bRangeSet False, basket, bLeft, bRight, bTop, bBottom

        For Each sp In .Shapes
            If sp.Name Like "ovl*" And Not sp.Visible Then
                sp.Visible = True
                Call Parabola(sp, Int((bLeft + sp.Width / 2 - (bRight - sp.Width / 2) + 1) * Rnd + (bRight - sp.Width / 2)), Int((bTop - sp.Height / 2 - (bBottom - sp.Height / 2) + 1) * Rnd + (bBottom - sp.Height / 2)))
            End If
        Next
    End With
    
 End Sub

 (ぶらっと)
----
ぶらっとさん、今拝見しました。
お忙しい中を本当に申し訳有りません。
素晴らしいの一言に尽きます。
子供の頃を思い出しました。
かごをグルグル早く回して係りの人から「もっとゆっくり回さないと玉が出てこない」と言われたのを思い出しています。
それでも早く回したい、今も同じ気持ちです。
気づいたことがもう一点あるのですがイイですか？
かごを最前面に移動させても回り出すと玉が最前面に出てきます。
玉はやっぱりかごの中に入っていないと・・・そして飛び出す。
一応回っている間はどんな動きをしているか、かごの中が見えるように透明度は１０％にして
そうするとシルエットが見えてリアルになります。
かごを常に前面にはならないでしょうか？
勝手ばかり言いワガママですみません。
(ラッキー男)
----
 >それでも早く回したい、今も同じ気持ちです。

 レベル２　にしても遅いということ？　
 ＰＣの性能や玉の数にも関係するけど、レベル２のスピードをあげる調整をしてみようか？

 >玉はやっぱりかごの中に入っていないと・・・そして飛び出す。 
 >一応回っている間はどんな動きをしているか、かごの中が見えるように透明度は１０％にして 
 >そうするとシルエットが見えてリアルになります。 
 >かごを常に前面にはならないでしょうか？ 

 がらがら　の　枠を若干太めにしたのかなと、そう思っていた。
 で、その太めの枠の裏側に玉が隠れてしまう・・
 そう理解したので、逆に、がらがら　を再背面にしたんだけど、そうじゃないんだね。
 極端に言えば　がらがらの枠というより、がらがら全体の下で　玉が動く。で、回っているときは
 シルエットが浮かび上がるようにする。

 そういうことだったのかな？
 ということなら、その線で　効果をつけることはできると思う。

 (ぶらっと)
----
 そちらの感覚に合うかどうか・・・・

 なお、がらがらの透明度については

 Private Const transBusy As Double = 0.1   '回っているときのがらがらの透明度               '★　追加
 Private Const transCalm As Double = 0.4   '止まっているときのがらがらの透明度             '★　追加

 ここで規定しているので、そちらの感覚に合うような数字に調整して。
 がらがらの回る速さ（というか、見た目）が、これでも遅いということなら、う〜ん・・・
 コードの上のほうの Const群での規定数値を増やしたり減らしたりして、調整お願い。（でも、限界はあるかな）

 なお、最初に、以下の Reset10　を実行して、がらがらの透明度をセットしておいてね。

 改訂した部分だけをアップするとかえってわかりにくくなると思うので　がらがら10、Reset10 として
 一式アップ。

 Option Explicit

 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
 Private Const adjustX As Long = 50     'バスケット領域内の"クライアント領域"の調整値
 '以下は状況に応じて数値を変更
 Private Const addRote1 As Long = 1     'レベル1 の各ボール位置移動後の回転角度単位
 Private Const addRote2 As Long = 1     'レベル2 の各ボール位置移動後の回転角度単位     '★　修正
 Private Const sleepA1 As Long = 10     'レベル1 の各ボール位置移動後のSleepミリ秒
 Private Const sleepA2 As Long = 0      'レベル2 の各ボール位置移動後のSleepミリ秒
 Private Const sleepB1 As Long = 20     'レベル1 の全ボール位置移動後のSleepミリ秒
 Private Const sleepB2 As Long = 1      'レベル2 の全ボール位置移動後のSleepミリ秒     '★　修正
 Private Const transBusy As Double = 0.1   '回っているときのがらがらの透明度               '★　追加
 Private Const transCalm As Double = 0.4   '止まっているときのがらがらの透明度             '★　追加
 
 Dim moveUp As Boolean      '★定義の場所を変更
 Dim addRote As Long        '★定義の場所を変更
    
 Sub がらがら10()
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim sp As Variant
    Dim winner As Shape
    Dim maxL As Double
    Dim winBall As Shape
    Dim basket As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim winLoop As Long
    Dim winSleep As Long
    Dim z As Long
    Dim hWnd As Long
    Dim i As Long
    Dim rtnS As Long
    Dim rtnZ As Long
    Dim rtnU As Long
    Dim rtnD As Long
    Dim udChange As Boolean
    Dim ballCnt As Long
    Dim sleepA As Long
    Dim sleepB As Long
    Dim BallOK As Boolean
    Dim svX As Double
    Dim svY As Double
 
    'モジュールレベル変数の初期化       '★追加
    addRote = 0
    moveUp = False
    
    With ActiveSheet

        If Not makeBall(v) Then
            MsgBox "回すボールがありませんよ"
            Exit Sub
        End If

        Set basket = .Shapes("basket")

        bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
 
        BallSet v, bLeft, bRight, bTop, bBottom, basket
        Set winner = .Shapes("Winner")
    End With
 
    Do
        rtnS = GetAsyncKeyState(vbKeyShift)
        If rtnS <> 0 Then Exit Do      'シフトキーがおされたら終了
        rtnD = GetAsyncKeyState(vbKeyDown)
        rtnU = GetAsyncKeyState(vbKeyUp)
        udChange = False
        If rtnU And &H80000000 <> 0 Then
            moveUp = True
            udChange = True
        ElseIf rtnD And &H80000000 <> 0 Then
            moveUp = False
            udChange = True
        End If
 
        If udChange Then
            bRangeSet moveUp, basket, bLeft, bRight, bTop, bBottom
        Else
            'がらがら実行
            basket.Fill.Transparency = transBusy     '★　追加
            addRote = addRote1
            sleepA = sleepA1
            sleepB = sleepB1
            If moveUp Then
                addRote = addRote2
                sleepA = sleepA2
                sleepB = sleepB2
            End If
            For Each sp In v
                BallSet v, bLeft, bRight, bTop, bBottom, basket
                basket.Rotation = (basket.Rotation + addRote) Mod 360
                Sleep sleepA
            Next
        End If
        Sleep sleepB
        DoEvents
    Loop
 
    For Each sp In v
        If sp.Visible Then
            If sp.Left > maxL Then
                maxL = sp.Left
                Set winBall = sp
            End If
        End If
    Next
 
    basket.Rotation = 0
 
    With winBall
        svX = .Left + .Width / 2
        svY = .Top + .Height / 2
    End With

    Call Parabola(winBall, winner.Left + winner.Width / 2, winner.Top + winner.Height / 2)
    winner.ZOrder msoSendToBack
 
    If MsgBox("おめでとうございます。このボールを勝ち抜けにしますか？", vbYesNo) = vbYes Then
        winBall.Visible = False
    Else
        Call Parabola(winBall, svX, svY)
    End If
    
    basket.Fill.Transparency = transCalm     '★　追加
    
 End Sub
 
 Private Sub BallSet(v As Variant, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double, basket As Shape)
    Dim sp As Variant
    For Each sp In v
        sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
        sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
        If moveUp Then basket.Rotation = (basket.Rotation + addRote) Mod 360        '★追加
    Next
    basket.ZOrder msoBringToFront       '★　変更
 End Sub
 
 Private Sub bRangeSet(moveUp As Boolean, basket As Shape, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double)
    With basket
        If moveUp Then
            bTop = .Top + .Height / 4
        Else
            bTop = .Top + .Height / 4 * 2.5
        End If
        bBottom = .Top + .Height - adjustX
        bLeft = .Left + adjustX
        bRight = .Left + .Width - adjustX
    End With
 End Sub
 
 Private Sub Parabola(myBall As Variant, p As Double, q As Double)
    Dim x As Double, y As Double
    Dim w As Double, h As Double
    Dim a As Double
    Const grids As Long = 50
    Dim graduation As Double
    Dim z As Long

    With myBall
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        w = .Width
        h = .Height
    End With

    graduation = (p - x) / grids

    a = (y - q) / (x - p) ^ 2

    For z = 1 To grids
 
        If z = grids Then
            x = p
            y = q
        Else
            x = x + graduation
            y = a * (x - p) ^ 2 + q
        End If

        myBall.Left = x - w / 2
        myBall.Top = y - h / 2
 
        Sleep 10
        DoEvents
        DoEvents

    Next

 End Sub
 
 Private Function makeBall(v() As Shape) As Boolean
    Dim sp As Shape
    Dim vFlag As Boolean

    With ActiveSheet
         For Each sp In .Shapes
            If sp.Name Like "ovl*" And sp.Visible Then
                If vFlag Then
                    ReDim Preserve v(1 To UBound(v) + 1)
                Else
                    ReDim v(1 To 1)
                    vFlag = True
                End If
                Set v(UBound(v)) = sp
                makeBall = True
            End If
        Next
    End With
 
 End Function

 Sub Reset10()
    Dim sp As Shape
    Dim bTop As Double, bLeft As Double, bRight As Double, bBottom As Double
    Dim v() As Shape
    Dim vFlag As Boolean
    Dim basket As Shape
 
    With ActiveSheet

        Set basket = .Shapes("basket")
        basket.ZOrder msoBringToFront       '★　追加
        basket.Fill.Transparency = transCalm     '★　追加
        
        bRangeSet False, basket, bLeft, bRight, bTop, bBottom
 
        For Each sp In .Shapes
            If sp.Name Like "ovl*" And Not sp.Visible Then
                sp.Visible = True
                Call Parabola(sp, Int((bLeft + sp.Width / 2 - (bRight - sp.Width / 2) + 1) * Rnd + (bRight - sp.Width / 2)), Int((bTop - sp.Height / 2 - (bBottom - sp.Height / 2) + 1) * Rnd + (bBottom - sp.Height / 2)))
            End If
        Next
        
    End With

 End Sub

 (ぶらっと)
----
 レベル１からレベル2に移行したときのがらがらの角度によっては、逆に、がらがらの回転が止まっているように
 見える場合がある。
 そういう場合は、↓キーでレベル1に戻した後、再度 ↑キーでレベル2にあげて試してみてね。

 (ぶらっと)
----
 addRote2 を 5 あたりにすると、比較的、安定して早く回っているように見えるかも。
 
 Private Const addRote2 As Long = 5     'レベル2 の各ボール位置移動後の回転角度単位     '★　修正

 それと、

 Private Const transBusy As Double = 0.05   '回っているときのがらがらの透明度               '★　追加

 このあたりにしておくとより、シルエットのような感じになるかな？

 (ぶらっと)
----
 どうも、レベル2 にしたときに回転が止まって見えるケースが増えた様な気がする・・・・
 このあたり、もう少し、あれこれ、いじってみるけど、そちらでの結果を教えてね・

 (ぶらっと)
----
 こちらで以下にすると、レベル2で、安定して回転している。

 Private Const addRote2 As Long = 10     'レベル2 の各ボール位置移動後の回転角度単位     '★　修正

 で、BallSet を

 Private Sub BallSet(v As Variant, bLeft As Double, bRight As Double, bTop As Double, bBottom As Double, basket As Shape)
    Dim sp As Variant
    For Each sp In v
        sp.Left = Int((bLeft - (bRight - sp.Width) + 1) * Rnd + (bRight - sp.Width))
        sp.Top = Int((bTop - (bBottom - sp.Height) + 1) * Rnd + (bBottom - sp.Height))
        If moveUp Then
            basket.Rotation = (basket.Rotation + addRote) Mod 360        '★追加
            DoEvents
        End If
    Next
    basket.ZOrder msoBringToFront       '★　変更
 End Sub


 (ぶらっと)
----
こんばんは、ぶらっとさん
ご返事・確認が遅くなり失礼しました。
完璧です！！、こんなの見たことがない！
素晴らしい仕上がりです。
わたしのワガママなお願いに１０度もの修正を頂き本当に感謝いたします。
きっと今もこれからも大勢の方が見られて驚愕することでしょう。
ありがとうございました。
(ラッキー男)