アクティブコントロールの移動

質問

初めて質問させていただきます。

Excelのシート上、一定の枠内にあるテキストボックスの中で
アクティブコントロールを取得し
決まったボタンで別枠内に集合させる、と言った内容のことを行いたいです。
具体的にはＡさん、Ｂさん、Ｃさんとテキストボックスがあり
ＡさんＢさんが出勤でＣさんが休暇の場合
Ｃさんをアクティブコントロールとして取得し
休暇枠ボタンで
休暇枠に飛ばしたいです。

ご教授願えれば幸いです・

回答No.3

Mathmi

No.2です。

質問だけでは何ですので、あるオートシェイプと重なっているオートシェイプを別のオートシェイプの場所に移動するコードを組んでみました。
出勤/欠勤の取得方法とか、移動先の位置とか、テキストボックスの判別方法とか、調整する箇所は多々存在するコードです。
ある程度VBAを分かっている人向けに、自分でコードを組むときに参考となる事を目的としたものです。

Sub test()
　Dim BaseShp As Shape '移動元枠オートシェイプ
　Dim BaseRange As Range '移動元枠セル範囲
　Dim MoveShp As Shape '移動先枠オートシェイプ
　Dim MoveRange As Range '移動先枠セル範囲
　Dim myShp As Shape
　Dim myRange As Range
　Dim BaseCollection As Collection '移動元に重なっているオートシェイプ
　Dim WorkCollection As Collection '出勤/休暇の組
　Dim MoveCollection As Collection '移動先に移動するオートシェイプ
　Dim MoveCell As Range '移動先のセル

　'移動先、移動元を取得
　Set BaseShp = ActiveSheet.Shapes("Rectangle 2")
　Set BaseRange = Range(BaseShp.TopLeftCell, BaseShp.BottomRightCell)
　Set MoveShp = ActiveSheet.Shapes("Rectangle 7")
　Set MoveRange = Range(MoveShp.TopLeftCell, MoveShp.BottomRightCell)

　'移動元と重なっているオートシェイプをコレクション。
　Set BaseCollection = New Collection
　For Each myShp In ActiveSheet.Shapes
　　Set myRange = Range(myShp.TopLeftCell, myShp.BottomRightCell)
　　If Not Intersect(BaseRange, myRange) Is Nothing And Not myShp Is BaseShp Then
　　　BaseCollection.Add myShp, myShp.TextFrame.Characters.Text
　　End If
　Next myShp

　'出勤/休暇を設定
　Set WorkCollection = New Collection
　WorkCollection.Add "出勤", "Aさん"
　WorkCollection.Add "休暇", "Bさん"
　WorkCollection.Add "休暇", "Cさん"

　'休暇のオートシェイプをコレクション
　Set MoveCollection = New Collection
　For Each myShp In BaseCollection
　　If WorkCollection.Item(myShp.TextFrame.Characters.Text) = "休暇" Then
　　　MoveCollection.Add myShp
　　End If
　Next myShp

　'休暇のオートシェイプを移動
　Set MoveCell = MoveShp.TopLeftCell
　For Each myShp In MoveCollection
　　myShp.Top = MoveCell.Top
　　myShp.Left = MoveCell.Left
　　Set MoveCell = MoveCell.Offset(myShp.BottomRightCell.Row - myShp.TopLeftCell.Row + 1)
　Next myShp
End Sub