Excel - 引かれたくじを回転させながら中央に移動する

クリックされたシェイプのオブジェクトを直接取得できないようなので、全シェイプを名前が一致するまでループし取得しています。直接取得する方法がおわかりの方教えてください。
オートシェイプのクジがクリックされると、回転しながら描画位置の中央に移動させます。
回転は　IncrementRotation　で10度単位で50回行います。
位置は現在位置を50で割り、分割分だけ50回移動させます。
その後、削除します。

シートのVBAコード

下記のVBAコードを追加してください。

Option Explicit

'Windowsが起動してからの経過時間 API
Private Declare Function GetTickCount Lib "kernel32" () As Long

'タイマー
Private Sub ExTimer(tim As Long)
    Dim st As Long

    '開始時間を取得
    st = GetTickCount
    DoEvents
    Do
        If GetTickCount - st >= tim Then
            '時間が経過した
            Exit Do
        End If
        DoEvents
    Loop
End Sub

'中央に移動
Private Sub ExMoveCenter(tshape As Shape)
    Dim xc As Long
    Dim yc As Long
    Dim i As Long
    Dim xf As Double
    Dim yf As Double

    'くじ描画範囲の中央位置を算出
    xc = (Sheets("くじ引き").Range("A1:K20").Width - tshape.Width) / 2
    yc = (Sheets("くじ引き").Range("A1:K20").Height - tshape.Height) / 2
    xf = (xc - tshape.Left) / 50
    yf = (yc - tshape.Top) / 50
    For i = 1 To 50
        tshape.Left = tshape.Left + xf
        tshape.Top = tshape.Top + yf
        '回転させる
        tshape.IncrementRotation 10
        'タイマー
        ExTimer 10
    Next
    '削除
    tshape.Delete
End Sub

下記のVBAコードに変更してください。

Public Sub ExShapeClick()
    Dim kname As String
    Dim tshape As Shape

    'クジの名前を取得
    kname = Application.Caller
    Range("A1") = kname
    'クジ番号
    Range("A2") = Mid(kname, 5)

    For Each tshape In Sheets("くじ引き").Shapes
        '名前をチェック
        If tshape.name = kname Then
            '中央に移動
            ExMoveCenter tshape
            Exit For
        End If
    Next
    Set tshape = Nothing
End Sub

■■■
このサイトの内容を利用して発生した、いかなる問題にも一切責任は負いませんのでご了承下さい
■■■
当ホームページに掲載されているあらゆる内容の無許可転載・転用を禁止します

Excelで三角くじを作ってみよう

Step 10　引かれたくじを回転させながら中央に移動する

シートのVBAコード

Excelで三角くじを作ってみよう

Step 10 引かれたくじを回転させながら中央に移動する

シートのVBAコード

Step 10　引かれたくじを回転させながら中央に移動する