エクセルのスピンボタンのコピーについて

質問

エクセルのスピンボタンのコピーについて
いろいろ検索し、試しましたがうまくいきません。

A2セルに氏名（A3,A4と下に1000人程います）
B1セルに日付（C1,D1と右に1ヶ月分）

B2セルにスピンボタンを設定し、そのスピンボタンを縦1000行、横30列にコピーしたいのですが
うまくいきません。。。

佐藤さんが12/1に3回⇒セルB2へ「３」
山田さんが12/2に5回⇒セルC3へ「５」
という感じで表示させたくて、B2へスピンボタンを設定しコピーしたのですがうまくいきません。
どうしたらできるでしょうか。

スピンボタンはフォームコントロールのものを使用しています。

Windows 7 Excel2007を使用しています。

回答No.2

tsubu-yuki · ベストアンサー

下側のコードは、該当シートのモジュールに書き込みます。

上のカエルの卵みたいなやつはオススメしませんよ。
シェイプが３万個はおそらくブック自体が反応しなくなると思います。
余程高スペックなパソコンなら話は別ですが・・・

お礼

ありがとうございます！できました！！！
仕事で使用するので困っていました。助かりましたm(__)m

回答No.1

tsubu-yuki

スピンボタンは「リンクしたセル」を保持したまま
コピー・貼り付けされてしまうので、
頑張って相当数をコピペしても徒労に終わってしまいますね。
　　※スピンボタンだけではないですが・・・

スピンボタン大量配置という手法の善し悪しは別にして、
「同じコントロールを大量に配置する」という、
アクセスのレポートではよくやる手段（に似た感覚のモノ）を使います。
ＶＢＡです。
Sub Sample()
Dim SpScale As Single
Dim TagRow As Long, TagCol As Long
Dim Target As Range

　　'一度すべてのシェイプを削除
　　For Each sh In ActiveSheet.Shapes
　　　　sh.Delete
　　Next

　　For TagRow = 2 To 5　　' 設置する行数
　　　　For TagCol = 2 To 10　　'設置する列数
　　　　　　Set Target = Cells(TagRow, TagCol)
　　　　　　　　SpScale = Target.Height
　　　　　　With ActiveSheet.Spinners.Add(Target.Left + Target.Width - SpScale, _
　　　　　　　　　　　　　　　　　　　　Target.Top, _
　　　　　　　　　　　　　　　　　　　　SpScale, _
　　　　　　　　　　　　　　　　　　　　SpScale)
　　　　　　　　.Name = Target.Address
　　　　　　　　.Value = 0
　　　　　　　　.Min = 0
　　　　　　　　.Max = 30000
　　　　　　　　.SmallChange = 1
　　　　　　　　.LinkedCell = Target.Address　　' ここが「リンクするセル」
　　　　　　　　.Display3DShading = True
　　　　　　End With
　　　　　　Target.HorizontalAlignment = xlCenter
　　　　Next TagCol
　　Next TagRow
End Sub
こんな感じで標準モジュールで実行してやります。
すると、画像の通り、気持ち悪いくらい全セルにスピンボタンがつきます。
３万個のスピンボタンですもんねぇ・・・（汗）

ちなみに、私のパソコン、そんなに低スペックとは思っていないのですが、
３万個のスピンボタンを並べるのに１５分かかりました。
下手したらフリーズするかもしれませんので、
お使いになるなら自己責任で、保存してから動かしてください。

まぁ、どちらにしてもボタンが小さすぎて使いづらい気がします。
なので、どうせＶＢＡを使うなら、ってことで
「フォーカスに追随して、スピンボタンが移動する」
ように組み直しました。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　' 名前が"Spin1"なシェイプがあったら削除
　　For Each sh In ActiveSheet.Shapes
　　　　If sh.Name = "Spin1" Then sh.Delete
　　Next

　　' スピンボタンを表示したいセル範囲はここで指定
　　' 指定範囲の「外」なら何もしないで終了
　　If Intersect(Target, Range("B1:J5")) Is Nothing Then Exit Sub

　　With ActiveSheet.Spinners.Add(Target.Left + Target.Width, _
　　　　　　　　　　　　　　　　Target.Top, _
　　　　　　　　　　　　　　　　24, 48)　　' スピンボタンのサイズはここ
　　　　　　　　　　　　　　　　　　　　　' なお、横, 縦で指定
　　　　.Name = "Spin1"　　' 名前は固定
　　　　.Value = Target.Value
　　　　.Min = 0
　　　　.Max = 30000
　　　　.SmallChange = 1
　　　　.LinkedCell = Target.Address
　　　　.Display3DShading = True
　　End With
　　Target.HorizontalAlignment = xlCenter
End Sub
これを該当シートのモジュールに書き込んでやればＯＫ。
これだと多分、スッキリ使える・・・はず(笑)。

ＶＢＡは使えん！となったら、手作業の力業でどうぞ。

補足

ありがとうございます！
tsubu-yukiさんの画像のようにしたいのです！
が、VBAが本当に苦手で・・・
組み直していただいたのも標準モジュールに張り付ければいいんでしょうか？？