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

質問

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

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

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

回答No.5

Mathmi

(前の回答より)

Sub ボタン()
　Dim i As Integer, j As Integer
　Dim NewGyoumu As Integer '変更先の業務番号
　Dim myShp
　Dim Bangou() As Integer '曜日番号、業務番号を受け取る配列。

　'何も選択されていなければ終了する。
　If VarType(Selection) <> vbObject Then
　　Exit Sub
　End If

　'ボタンの名前から業務番号を設定する。
　Select Case ActiveSheet.Buttons(Application.Caller).text
　　Case "業務1"
　　　NewGyoumu = 1
　　Case "業務2"
　　　NewGyoumu = 2
　　Case "業務3"
　　　NewGyoumu = 3
　　Case "業務4"
　　　NewGyoumu = 4
　End Select

　'枠や名札位置、名前一覧を読み込み
　Call 設定
　Call 名札取得

　'データ上の業務番号を変更
　For Each myShp In Selection.ShapeRange
　　For i = 1 To UBound(Nafuda)
　　　If myShp Is Nafuda(i).shp Then
　　　　Nafuda(i).Gyoumu = NewGyoumu
　　　End If
　　Next i
　Next myShp

　'名札の位置を変更
　For i = 1 To nYoubi
　　For j = 1 To nGyoumu
　　　Call 枠再描画(i, j)
　　Next j
　Next i
End Sub

Sub 名札取得()
'画面内のオートシェイプの内、枠に含まれているものを検索。
'先に枠の設定を読み込む必要がある。
　Dim n As Integer
　Dim Bangou() As Integer
　Dim myShp As Shape

　For Each myShp In wsHyouji.Shapes
　　Bangou = 名札検索(myShp)
　　If Bangou(1) <> -1 Then '枠に含まれていれば
　　　n = n + 1
　　　ReDim Preserve Nafuda(1 To n)
　　　Set Nafuda(n).shp = myShp
　　　Nafuda(n).Youbi = Bangou(1)
　　　Nafuda(n).Gyoumu = Bangou(2)
　　　Nafuda(n).Key = myShp.TextFrame.Characters.text
'　　　myShp.Width = 50
'　　　myShp.Height = 20.25
　　End If
　Next myShp
End Sub

Function 名札検索(ByRef myShp As Shape) As Integer()
'そのオートシェイプが、どの枠の中に含まれているかを返す。
'先に枠の設定を読み込む必要がある。
　Dim i As Integer, j As Integer
　Dim aryRtn(1 To 2) As Integer '戻り値用配列

　'テキストボックスでないなら、異常を返して終了
　If myShp.Type <> msoTextBox Then
　　GoTo CONTINUE
　End If

　'枠なら、異常を返して終了
　For i = 1 To nYoubi
　　For j = 1 To nGyoumu
　　　If myShp Is Waku(i, j).shp Then
　　　　GoTo CONTINUE
　　　End If
　　Next j
　Next i

　'どの枠に含まれているか
　For i = 1 To nYoubi
　　For j = 1 To nGyoumu
　　　If Waku(i, j).Top <= myShp.Top And myShp.Top <= Waku(i, j).Bottom And _
　　　 Waku(i, j).Left <= myShp.Left And myShp.Left <= Waku(i, j).Right Then
　　　　aryRtn(1) = i
　　　　aryRtn(2) = j
　　　　名札検索 = aryRtn
　　　　Exit Function
　　　End If
　　Next j
　Next i

CONTINUE:
　aryRtn(1) = -1
　名札検索 = aryRtn
End Function

Sub 枠再描画(ByRef bi As Integer, ByRef Gyou As Integer)
'bi曜日の業務Gyouの枠に含まれる名札を並び替える。
　Dim i As Integer, j As Integer, n As Integer, cnt As Integer
　Dim TargetNafuda() As NamePlate '作業対象である名札

　'名札一覧からその枠内の名札のみを抽出
　For i = 1 To UBound(Nafuda)
　　If Nafuda(i).Youbi = bi And Nafuda(i).Gyoumu = Gyou Then
　　　n = n + 1
　　　ReDim Preserve TargetNafuda(1 To n)
　　　TargetNafuda(n) = Nafuda(i)
　　End If
　Next i

　'その枠に名札が含まれていなければ終了
　If n = 0 Then
　　Exit Sub
　End If

　'抽出した名札を、名前の順番で並び替え
　cnt = 0
　For i = 0 To UBound(Namae)
　　For j = 1 To UBound(TargetNafuda)
　　　If Namae(i) = TargetNafuda(j).Key Then
　　　　cnt = cnt + 1
　　　　TargetNafuda(j).shp.Left = Waku(bi, Gyou).Left + NafudaWaku(cnt).X
　　　　TargetNafuda(j).shp.Top = Waku(bi, Gyou).Top + NafudaWaku(cnt).Y
　　　End If
　　Next j
　Next i
End Sub
******************************

＞色々な無理な要求を短期間で解決するよう依頼が上がってきます。
プログラムが分かっていない人だと「この程度簡単でしょ」って気持ちで投げてくる時があるので、大変だとは思いますが、頑張って下さい。
コードを書いたり読み解いたりしていると、確実にスキルアップしますので。