No title
VBA
’ブックモジュールに記述
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 SelectRng As Range 'Selectionを保持するための変数
Dim visiRng As Range '現在画面に表示されているセル範囲
Set visiRng = ActiveWindow.VisibleRange
Set activeRng = ActiveCell
Set SelectRng = Selection
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
SelectRng.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
Excelファイル一括オープン