'ブックモジュールに記述

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shpCat          As Shape        '動作する画像
    Dim shpAroundRng    As Range        'ShpCatの配置されているセル範囲
    Dim appearRng       As Range        'ShpCatが出現するセル
    Dim activeRng       As Range        'ActiveCellを保持するための変数
    Dim visiRng         As Range        '現在画面に表示されているセル範囲
    Set visiRng = ActiveWindow.VisibleRange
    Set activeRng = ActiveCell
    
    Application.EnableEvents = False
    
    Set shpCat = getShp(shpName:="cat")
    Call delShp(shpName:="テキスト")
    
    If Not shpCat Is Nothing Then
        
        Set shpAroundRng = shpCat.Parent.Range(shpCat.TopLeftCell, shpCat.BottomRightCell)
        Set appearRng = getAppearRng(visiRng)
        Select Case True
            Case shpCat.Parent.Name <> Sh.Name, Intersect(visiRng, shpAroundRng) Is Nothing '画面内にShpCatが無ければ、shpCatをカットしappearRngに貼り付ける
                shpCat.Cut
                appearRng.Select
                Sh.Paste
                Set shpCat = Sh.Shapes(Selection.Name)
                Target.Select
        End Select
        
        
        Call 猫寄ってくる(activeRng, shpCat)
        
    End If
    
    activeRng.Select
    Application.EnableEvents = True
    
End Sub


Private Function getShp(ByVal shpName As String) As Shape
    '名前がShpNameのShapeがSetされ次第関数を抜ける
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        Set getShp = ws.Shapes(shpName)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next

End Function

Private Sub delShp(ByVal shpName As String)
    'ブック内の全てのShpNameのShapeを削除する
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Shapes(shpName).Delete
    Next

End Sub

Private Function getAppearRng(ByVal rng As Range) As Range
    '引数rngの四隅(の一つ内側)のセルの内いずれかをランダムで返す関数
    '1:左上
    '2:右上
    '3:左下
    '4:右下
    
    Randomize
    Dim rndNum As Long
    rndNum = Int(Rnd * 4) + 1
    
    Select Case rndNum
        Case 1:     Set getAppearRng = rng(1).Offset(1, 1)
        Case 2:     Set getAppearRng = rng.Offset(, rng.Columns.Count - 1).Item(1).Offset(1, -1)
        Case 3:     Set getAppearRng = rng.Offset(rng.Rows.Count - 1).Item(1).Offset(-1, 1)
        Case 4:     Set getAppearRng = rng(rng.Count).Offset(-1, -1)
    End Select
        
    
End Function


Private Sub 猫寄ってくる(ByVal rng As Range, ByVal shp As Shape)
    'shpの縦位置がrngの縦位置に達するまで縦移動し続ける
    'shpの横位置がrngの横位置に達するまで横移動し続ける
    'shpとrngの位置が一致したらループを抜ける
    
    Dim sphCenterV      As Double   'shpの縦中央位置
    Dim sphCenterH      As Double   'shpの横中央位置
    Dim rngCenterV      As Double   'rngの縦中央位置
    Dim rngCenterH      As Double   'rngの横中央位置
    Dim beforeShpArea   As String   'shpの1ステップ移動前位置
    Dim afterShpArea    As String   'shpの1ステップ移動後位置
    Dim flgV            As Boolean  'shpの縦位置がrngの縦位置に達したらTrueにする
    Dim flgH            As Boolean  'shpの横位置がrngの横位置に達したらTrueにする
    Const speed As Double = 6
    
    rngCenterV = rng.Top + rng.Height / 2
    rngCenterH = rng.Left + rng.Width / 2
    
    Do
        DoEvents
        
        sphCenterV = shp.Top + shp.Height / 2
        sphCenterH = shp.Left + shp.Width / 2
        
        beforeShpArea = shp.Top & "|" & shp.Left
        If Not flgV Then shp.Top = IIf(sphCenterV - rngCenterV < 0, shp.Top + speed, shp.Top - speed)
        If Not flgH Then shp.Left = IIf(sphCenterH - rngCenterH < 0, shp.Left + speed, shp.Left - speed)
        afterShpArea = shp.Top & "|" & shp.Left
        
        
        If Abs(sphCenterV - rngCenterV) < speed Then flgV = True
        If Abs(sphCenterH - rngCenterH) < speed Then flgH = True
        
        If flgV And flgH Then Exit Do
        If afterShpArea = beforeShpArea Then Exit Do
        
        Application.Wait [Now()] + 0.001 / 86400
    Loop
    
    
    Call にゃーと鳴く(shp, shp.Parent)
    
    
    
End Sub



Private Sub にゃーと鳴く(ByVal shp As Shape, ByVal ws As Worksheet)
    'shpの右隣にテキストボックスを配置して「にゃーー」と入力するにゃ。
    
    Dim テキストTop     As Double
    Dim テキストleft    As Double
    Dim テキスト        As Shape
    
    テキストTop = shp.Top
    テキストleft = shp.Left + shp.Width

    ws.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=テキストleft, _
            Top:=テキストTop, _
            Width:=100, _
            Height:=60).Select
    
    With Selection
        .Name = "テキスト"
        .ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        .ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.Fill.ForeColor.RGB = 11854022
        .ShapeRange.Line.ForeColor.RGB = 0
        .ShapeRange.TextFrame.Characters.Text = "にゃーー"
        .ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
        .ShapeRange.TextFrame2.TextRange.Font.Size = 16
    End With
    
End Sub

• Like
• LINE
• Tweet
• Copy URL