チェックボックスのリンクするセル一括設定

質問

似たような質問を送ったのですが、

B2のチェックボックスのリンクがsheet２のB2
B3のチェックボックスのリンクがsheet２のB3
...
というのはできたのですが、
D2のチェックボックスのリンクがsheet２のD2
...

というVBAを作ると、B列のリンクが消えてしまいます。

どのようなVBAを書けばよいでしょうか。

回答No.3

m3_maki · ベストアンサー

こんな感じ。

Sub Sample()
Dim chk As CheckBox
For Each chk In Worksheets("Sheet1").CheckBoxes
chk.LinkedCell = "Sheet2!" & chk.TopLeftCell.Address
Next
End Sub

回答No.2

HohoPapa

https://okwave.jp/qa/q9966921.html
の話と思います。
この時のコードは
>チェックボックスが数10個あるので
という条件で
かつ、1行に複数のチェックボックスがあることを想定し提示したコードです。
つまり、９９個以内です。

今回のケースであれば、後記コードでイケルと思います。

Sub sample()

　Dim sh As Shape
　Dim LineNum As Long

　For Each sh In ActiveSheet.Shapes
　　If Left(sh.Name, 9) = "Check Box" Then
　　　'何行目にあるかを調べる
　　　LineNum = SearchR(sh.Top + (sh.Height / 2))
　　　'リンクセルを設定

　　　sh.Select
　　　If sh.Left < Columns("C").Left Then
　　　　Selection.LinkedCell = "Sheet2!$B$" & Format(LineNum, "0")
　　　ElseIf sh.Left < Columns("E").Left Then
　　　　Selection.LinkedCell = "Sheet2!$D$" & Format(LineNum, "0")
　　　End If
　　End If
　Next sh

End Sub

'縦位置から該当行番号を取得する関数
Function SearchR(MyTop As Double) As Long

　Const MaxRows = 10000　'最大行数
　Dim r As Long

　For r = 1 To MaxRows
　　If ((Cells(r, 1).Top < MyTop) And _
　　　　(Cells(r, 1).Top + Cells(r, 1).Height > MyTop)) Then
　　　SearchR = r
　　　Exit Function
　　End If
　Next r

End Function

回答No.1

m3_maki

> というVBAを作ると、B列のリンクが消えてしまいます。

どんなコードですか？

補足

載せるの忘れました。こちらのコードです。
https://okwave.jp/qa/q9966921.html