コンボボックスの貼りつけ excel

質問

vba初心者です。excel帳簿を作っております。
科目選択時にリストが28個あるプルダウンを使っておりましたが選択するのが大変だったのでコンボボックスにしたら28個全て表示されるようになり選択が楽になりました。

このコンボボックスのLinkedCellはD4です。
コンボボックスをD4の上に表示してD4セルにピッタリはめ込んでいる感じに見えます。

D4以下150個、D列にコンボボックスを貼りつけたいです。

コピーして貼り付けてもLinkedCellはD4のままですので、貼りつけたコンボボックスのプロパティを150回変えないといけないのかと思うと気が遠くなります。

このコンボボックスを何か登録して、「コードの表示」あたりで何かやれば何とかなるのではないかと思ったのですが、何か手立てがあれば教えてください。

このコンボボックスを同じブックの別のシートにも使いたいと思っております。

回答No.4

watabe007

D5セルから新たに150個のコンボボックスを追加しました。
Sub Test()
　　Dim c As Range
　　For Each c In Range("D5:D154")
　　　　With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1")
　　　　　　.Left = c.Left
　　　　　　.Top = c.Top
　　　　　　.Width = c.Width
　　　　　　.Height = c.Height
　　　　　　.ListFillRange = "Sheet2!A2:A29" 'リスト範囲を設定
　　　　　　.LinkedCell = c.Address 'リンクセル
　　　　End With
　　Next
End Sub

回答No.3

kkkkkm

もし、ちらちらするのが気になるようでしたら
以下のようにApplication.ScreenUpdatingをいれると解消されると思いますが、常時実行するものでもないと思いますので、ちらちらしたほうが動いてる感じがわかっていいかもしれません。
Sub Test2()
Dim i As Long
Dim mCombo As ComboBox
Application.ScreenUpdating = False
For i = 5 To 8
ActiveSheet.Shapes.Range(Array("ComboBox1")).Select
Selection.Copy
Cells(i, "D").Select
ActiveSheet.Paste
Set mCombo = ActiveSheet.OLEObjects(Selection.ShapeRange.Name).Object
mCombo.Top = Cells(i, "D").Top
mCombo.Left = Cells(i, "D").Left
mCombo.LinkedCell = "D" & i
Set mCombo = Nothing
Next
Application.ScreenUpdating = True
End Sub

回答No.2

kkkkkm

No1の補足です。
テストでできたコンボボックスは実際に実行する前に削除してください。削除しないと、実際に実行した場合同じものが重なって作成されます。

回答No.1

kkkkkm

これでいけると思います。一応D5からD8までにしてますのでうまくいけば実際の行数まで増やしてください。ComboBox1は実際のコンボボックス名にしてください。
Sub Test()
Dim i As Long
Dim mCombo As ComboBox
For i = 5 To 8
ActiveSheet.Shapes.Range(Array("ComboBox1")).Select
Selection.Copy
Cells(i, "D").Select
ActiveSheet.Paste
ActiveSheet.Shapes(Selection.ShapeRange.Name).Top = Cells(i, "D").Top
ActiveSheet.Shapes(Selection.ShapeRange.Name).Left = Cells(i, "D").Left
Set mCombo = ActiveSheet.OLEObjects(Selection.ShapeRange.Name).Object
mCombo.LinkedCell = "D" & i
Set mCombo = Nothing
Next
End Sub