| |
▼yasu さん：
面白そうなのでオートシェイプのアークを使って作ってみました。
半切りドーナツをAdjustmentsを使ってで扇形にして回転しました。
初級者ですからこの程度が精一杯です。
>>「セルに入力されている値から色を付ける」という処理は、
>>やる気があれば出来ます。
>
>
>どのようにすればよいのでしょうか…
>
シートに以下の様に入力されているとして
A B C D E .......R
1番号 1 2 3 4 .......17
2色番号4 8 1 6 ....適当に
Sub 区切りドーナツ()
Dim rr As Double '半径
Dim 個数 As Integer '1つの輪を区切る数
Dim θ As Long, zure As Long '回転角度とずらす角度
Dim 番号 As Long '作った扇に名前を付ける。色を付ける時に使う
'図形に名前を付けているから既にドーナツが表示されていたらエラーになる
If ActiveSheet.Shapes.Count > 0 Then
MsgBox "図形を全て消してから実行してください"
Exit Sub
End If
'一番外の60度の扇を六つ描く。番号は12番〜17番
rr = 100
個数 = 6
θ = 180 - (180 - 60) / 2
zure = 0
番号 = 12
Make_Ougi 個数, rr, θ, zure, 番号
'外から2番目の扇を六つ描く番号は6番〜11番
個数 = 6
rr = 80
θ = 180 - (180 - 60) / 2
zure = 30 ' 外の扇と30度ずらす
番号 = 6
Make_Ougi 個数, rr, θ, zure, 番号
'3番目の90度の扇を四つ描く。番号は2番〜5番
個数 = 4
rr = 60
θ = 180 - (180 - 90) / 2
zure = 30
番号 = 2
Make_Ougi 個数, rr, θ, zure, 番号
'最後に中心の円を描く
rr = 40
ActiveSheet.Shapes.AddShape(msoShapeOval, 300 - rr, 300 - rr, 2 * rr, 2 * rr).Select
Selection.Name = "扇1"
'セルB2からセルR2に入力されている色番号で塗りつぶす。
For i = 1 To 17
ActiveSheet.Shapes("扇" & i).Fill.ForeColor.SchemeColor = Cells(2, i + 1).Value
Next
End Sub
Sub Make_Ougi(ByVal 個数 As Integer, ByVal rr As Double, _
ByVal θ As Long, ByVal θ2 As Long, ByVal Num As Long)
Dim i As Integer
Dim x As Double, y As Double '中心座標
x = 300
y = 300
For i = 0 To 個数 - 1
With ActiveSheet.Shapes.AddShape(msoShapeBlockArc, x - rr, y - rr, 2 * rr, 2 * rr)
.Adjustments.Item(1) = θ
.Adjustments.Item(2) = 0
.Rotation = 360 / 個数 * i + θ2
.Name = "扇" & Num + i '取り敢えず図形に名前を付けておく
End With
Next i
End Sub
|
|
yata
- 07/11/7(水) 21:46 -
