こんにちは。
朝から、ずっと、かなり試行錯誤を繰り返しました。
やっとサマになったのですが、不確定要素がかなりあって、もしかすると、うまく行かないのではないか、と思います。
フォーム・ツールは、コントロールツールよりは軽いけれども、数が多くなると動かなくなる可能性もあります。その場合は、例えば、ダブルクリック・イベントなどに換えてしまったほうが確実ですね。
なお、現在は、「距離」は、G列(7列目)に出力させるようになっております。7列目ではなければ、Const COL As Integer = 7 の部分を変更してください。
また、行の高さは、13.5 を標準にして作られていますので、それ以下では、誤動作の可能性があります。なるべく、新規のシートでお試しになったほうがよいです。
以下は、おまけとして、消去プログラムがついています。
以下のコードは、必ず、<標準モジュール>に設定してください。
'-----------------------------------------------
Option Explicit
Private Const FIRST_ROW As Integer = 1 '始まりの行
Private Const LAST_ROW As Integer = 80 '終わりの行
Private Const COL As Integer = 7 '7列目に出す
Sub AddOptionButton_Groups()
'フォームツール
Dim i As Long
Dim j As Integer
Dim GB As Object
Dim DefaultRowHeigth As Double
DefaultRowHeigth = ActiveSheet.Cells.EntireRow.RowHeight
For i = FIRST_ROW To LAST_ROW + FIRST_ROW - 1
With ActiveSheet.Cells(i, 1)
For j = 0 To 5
Set GB = ActiveSheet.GroupBoxes.Add(.Left, .Top, .Resize(, 6).Width, .Height)
With GB
.Text = ""
.Visible = False 'グループボックスのラインが消す
End With
With ActiveSheet.OptionButtons.Add(.Offset(, j).Left + .Width / 2, .Offset(, j).Top, .Offset(, j).Height, .Offset(, j).Height)
.OnAction = "OBIndexOut"
.Caption = ""
.Locked = True
.LockedText = True
End With
Next j
GB.Height = DefaultRowHeigth '高さを再設定
End With
Next i
End Sub
Sub OBIndexOut()
'LinkedCell の変り
Dim rng As Range
Set rng = ActiveSheet.OptionButtons(Application.Caller).TopLeftCell
ActiveSheet.Cells(rng.Row, COL).Value = rng.Column
Set rng = Nothing
End Sub
'===============================================
Sub ObjectClear()
'おまけ-フォームツールを全部消去
ActiveSheet.GroupBoxes.Delete
ActiveSheet.OptionButtons.Delete
ActiveSheet.Columns(COL).ClearContents
End Sub
お礼
回答有難う御座いました。 やりたかった事はバッチリこれでした。 ただやはり容量が大きくなりました。 一度これで作成してアクセスでも作ってみようと思います。