|
コードではコピー後、削除してしまします。
この画像はその後ペーストをした結果です。
|
|
|
| シートコード |
|
下記のコードに変更してください。
'作成開始ボタン
Private Sub CommandButton1_Click()
Dim ln1 As Long
Dim ln2 As Long
ln1 = MyGetSuchi("C2")
If ln1 <= 0 Or ln1 > 100 Then
MsgBox "くじ枚数は1〜100の範囲で入力してください。"
Exit Sub
End If
ln2 = MyGetSuchi("C3")
If ln2 < 0 Or ln2 > ln1 Then
MsgBox "当たり枚数は,くじ枚数より少なくしてください。"
Exit Sub
End If
Range("C2") = ln1
Range("C3") = ln2
ExMakeShape
End Sub
下記のコードを追加してください。
Sub ExMakeShape()
Dim tshape As Shape
Set tshape = Sheets("くじ引き").Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Left:=0, Top:=0, Width:=216, Height:=94.5)
'塗りつぶし
tshape.Fill.Visible = True
'透明度
tshape.Fill.Transparency = 0.5
'塗りつぶし色
tshape.Fill.ForeColor.RGB = vbRed
'文字をセット
tshape.TextFrame.Characters.Text = "三角くじ"
'文字色
tshape.TextFrame.Characters.Font.ColorIndex = 0
'太字
tshape.TextFrame.Characters.Font.Bold = True
'サイズ
tshape.TextFrame.Characters.Font.Size = 16
'中央に表示
tshape.TextFrame.HorizontalAlignment = xlCenter
'選択
tshape.Select
'コピー
tshape.Copy
'削除
tshape.Delete
Set tshape = Nothing
End Sub
|
|
|
|
|
|
|
|