Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


5161 / 13646 ツリー ←次へ | 前へ→

【52287】図を作って色分け…お急ぎ頂けると光栄です yasu 07/11/5(月) 17:54 質問[未読]
【52288】Re:図を作って色分け…お急ぎ頂けると光栄... ぱっせんじゃー 07/11/5(月) 18:03 発言[未読]
【52289】Re:図を作って色分け…お急ぎ頂けると光栄... yasu 07/11/5(月) 18:23 質問[未読]
【52293】Re:図を作って色分け…お急ぎ頂けると光栄... ichinose 07/11/5(月) 21:39 発言[未読]
【52295】Re:図を作って色分け…お急ぎ頂けると光栄... [名前なし] 07/11/6(火) 0:02 質問[未読]
【52296】Re:図を作って色分け…お急ぎ頂けると光栄... ichinose 07/11/6(火) 7:46 発言[未読]
【52298】Re:図を作って色分け…お急ぎ頂けると光栄... yasu 07/11/6(火) 13:40 質問[未読]
【52312】Re:図を作って色分け…お急ぎ頂けると光栄... yata 07/11/7(水) 21:46 発言[未読]
【52316】Re:図を作って色分け…お急ぎ頂けると光栄... yasu 07/11/8(木) 15:23 質問[未読]
【52322】Re:図を作って色分け…お急ぎ頂けると光栄... yata 07/11/8(木) 21:24 発言[未読]

【52287】図を作って色分け…お急ぎ頂けると光栄で...
質問  yasu  - 07/11/5(月) 17:54 -

引用なし
パスワード
   Basicを触ったことがありません。。。

そんな私ですが、以下のような物を作れと言われました。
わかりません。できません。助けてください。。

    _______
   /       \
  /\ _____ /\
 /  /     \  \
/  /\ ___ /\  \
|  /  /   \  \  |
|  |  /\ _ /\  | |
|__|_|  / \  |_|_|
|  | |  \_/  | | |
|  |  \/   \/  | |
|  \  \___/  /  |
\  \/     \/  /
  \  \_____/  /
   \/       \/
    \_______/

まず、図のような"円"を作成したいのです。
四つの円が重なっており、外に6分割された2つの円、その中に4分割された円、
さらにその中に円です。

そして、6×2+4+1=17個に区分されたそれぞれに、
エクセルのセルに入力した値に対応させて色をつけたいのです。
(セルの値が1なら青 → 256なら赤 と値にあわせて色を変化させたいのです)

説明が下手ですいません。理解できない部分がありましたら聞いていただければ努力いたしますので、どうか皆様ご協力のほど宜しくお願いいたします。。。

【52288】Re:図を作って色分け…お急ぎ頂けると光...
発言  ぱっせんじゃー  - 07/11/5(月) 18:03 -

引用なし
パスワード
   なんとなく、ですが、「グラフ」で出来るかもしれません。
>そして、6×2+4+1=17個に区分されたそれぞれに、
>エクセルのセルに入力した値に対応させて色をつけたいのです。

17個はすべて同じ色ですか?別々の色ですか?

【52289】Re:図を作って色分け…お急ぎ頂けると光...
質問  yasu  - 07/11/5(月) 18:23 -

引用なし
パスワード
   17個は基本的には別々の色ですが、セルに入れた値が同じなら同じ色となります。

エクセルに
番号 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
値  ○ △ □ ……

と入れ、
ある番号の値が1ならその番号に対応したところは青で塗られる
256なら赤く塗られる 128なら中間色。
となるようにしたいのです。わかりますか??
本当に説明が下手ですみません

【52293】Re:図を作って色分け…お急ぎ頂けると光...
発言  ichinose  - 07/11/5(月) 21:39 -

引用なし
パスワード
   ▼yasu さん:
こんばんは。

>Basicを触ったことがありません。。。

「他の言語なら、知っている」という事ですか?


サンプルです。

新規ブックの標準モジュールに
'==================================================================
Sub main()
  Dim idx As Double
  Dim shp As Shape
  Dim col As Long
  col = 1
  For idx = -30 To 270 Step 60
   Set shp = Mk_enko(ActiveSheet, 300, 300, 120, idx, idx + 60, col)
   col = col + 1
   Next
  For idx = -30 To 270 Step 60
   Set shp = Mk_enko(ActiveSheet, 300, 300, 90, idx, idx + 60, col)
   col = col + 1
   Next
  For idx = -45 To 225 Step 90
   Set shp = Mk_enko(ActiveSheet, 300, 300, 60, idx, idx + 90, col)
   col = col + 1
   Next
  Set shp = Mk_enko(ActiveSheet, 300, 300, 30, 0, 360, col, False)
  
   
End Sub
'=========================================================================
Function Mk_enko(ByVal sht As Worksheet, ByVal x As Double, ByVal y As Double, _
         ByVal rs As Double, ByVal std As Double, ByVal edd As Double, _
         ByVal col As Long, Optional ByVal gen As Boolean = True) As Shape
'円弧を作成する
'sht-----作成するシート
'x,y-----中心座標
'rs------半径
'std----開始角度
'edd----終了角度
'col----塗りつぶす色
'gen----True 弦を描く False 弦なし
'出力---Mk_enko--Shapeオブジェクト
  Dim sttX As Double
  Dim sttY As Double
  Dim pai As Double
  Dim strd As Double
  Dim edrs As Double
  Dim idx As Double
  pai = WorksheetFunction.Pi
  strd = (1.5 - std / 180) * pai
  edrs = (1.5 - edd / 180) * pai
  If gen = True Then
   sttX = x
   sttY = y
  Else
   sttX = x + rs * Cos(strd)
   sttY = y + rs * Sin(strd)
   strd = strd - 0.15
   End If
  With sht.Shapes.BuildFreeform(msoEditingAuto, sttX, sttY)
   For idx = strd To edrs Step -0.001
     .AddNodes msoSegmentLine, msoEditingAuto, x + rs * Cos(idx), y + rs * Sin(idx)
     Next idx
   If gen = True Then .AddNodes msoSegmentLine, msoEditingAuto, x, y
   Set Mk_enko = .ConvertToShape
   With Mk_enko.Fill
     .Visible = msoTrue
     .ForeColor.SchemeColor = col
     End With
   End With
End Function


mainを実行してください。


>
>そんな私ですが、以下のような物を作れと言われました。
>わかりません。できません。助けてください。。
>
>     _______
>    /       \
>   /\ _____ /\
>  /  /     \  \
> /  /\ ___ /\  \
>|  /  /   \  \  |
>|  |  /\ _ /\  | |
>|__|_|  / \  |_|_|
>|  | |  \_/  | | |
>|  |  \/   \/  | |
>|  \  \___/  /  |
> \  \/     \/  /
>  \  \_____/  /
>   \/       \/
>    \_______/
>
↑これと似たようなものが作成されるはずです。

後は、研究してみてください。

【52295】Re:図を作って色分け…お急ぎ頂けると光...
質問  [名前なし]  - 07/11/6(火) 0:02 -

引用なし
パスワード
   他もないです…
まったくないです…

教えてください

【52296】Re:図を作って色分け…お急ぎ頂けると光...
発言  ichinose  - 07/11/6(火) 7:46 -

引用なし
パスワード
   ▼[名前なし] さん:
>>Basicを触ったことがありません。。。
>他もないです…
>まったくないです…

>>そんな私ですが、以下のような物を作れと言われました。
だとしたら、これは無理なことです。

前回の投稿でVBAを使えば、投稿された命題は実現可能である 
というサンプルコードは掲載しました。

そのコードをどこに記述するのかがわからないのであれば、
「VBEの使い方」等を検索キーにして調べてみてください。

17個の分割された円または、扇は作成されます。

「セルに入力されている値から色を付ける」という処理は、
やる気があれば出来ます。

17個ぐらいなら、最悪手動で色を付けても手間は知れています。

私が協力できるのはここまでです。

【52298】Re:図を作って色分け…お急ぎ頂けると光...
質問  yasu  - 07/11/6(火) 13:40 -

引用なし
パスワード
   >「セルに入力されている値から色を付ける」という処理は、
>やる気があれば出来ます。


どのようにすればよいのでしょうか…

形は望むものができました。
ありがとうございます!助かります。

【52312】Re:図を作って色分け…お急ぎ頂けると光...
発言  yata  - 07/11/7(水) 21:46 -

引用なし
パスワード
   ▼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

【52316】Re:図を作って色分け…お急ぎ頂けると光...
質問  yasu  - 07/11/8(木) 15:23 -

引用なし
パスワード
   円を作ることは望んでいたものができました。
ありがとうございました。

続いて、色をつけるということをしたいのですが、
したのように作ってみたら意外とできたので驚いたのですが、
もうちょっとかんたんにはならないでしょうか??

あと、255±Range や 0±Range といった値が255を超える
または0を下回った際には255、0にするというようにするには
どうしたらよいでしょうか??

ご協力お願いします。

Sub 色()
 Worksheets("Sheet1").Shapes(1).Fill _
 .ForeColor.RGB = RGB(Range("a1"), 255 - Range("a1"), 255 + Range("a1"))
 Worksheets("Sheet1").Shapes(2).Fill _
 .ForeColor.RGB = RGB(Range("b1"), 255 - Range("b1"), 255 + Range("b1"))
 Worksheets("Sheet1").Shapes(3).Fill _
 .ForeColor.RGB = RGB(Range("c1"), 255 - Range("c1"), 255 + Range("c1"))
 Worksheets("Sheet1").Shapes(4).Fill _
 .ForeColor.RGB = RGB(Range("d1"), 255 - Range("d1"), 255 + Range("d1"))
 Worksheets("Sheet1").Shapes(5).Fill _
 .ForeColor.RGB = RGB(Range("e1"), 255 - Range("e1"), 255 + Range("e1"))
 Worksheets("Sheet1").Shapes(6).Fill _
 .ForeColor.RGB = RGB(Range("f1"), 255 - Range("f1"), 255 + Range("f1"))
 Worksheets("Sheet1").Shapes(7).Fill _
 .ForeColor.RGB = RGB(Range("g1"), 255 - Range("g1"), 255 + Range("g1"))
 Worksheets("Sheet1").Shapes(8).Fill _
 .ForeColor.RGB = RGB(Range("h1"), 255 - Range("h1"), 255 + Range("h1"))
 Worksheets("Sheet1").Shapes(9).Fill _
 .ForeColor.RGB = RGB(Range("i1"), 255 - Range("i1"), 255 + Range("i1"))
 Worksheets("Sheet1").Shapes(10).Fill _
 .ForeColor.RGB = RGB(Range("j1"), 255 - Range("j1"), 255 + Range("j1"))
 Worksheets("Sheet1").Shapes(11).Fill _
 .ForeColor.RGB = RGB(Range("k1"), 255 - Range("k1"), 255 + Range("k1"))
 Worksheets("Sheet1").Shapes(12).Fill _
 .ForeColor.RGB = RGB(Range("l1"), 255 - Range("l1"), 255 + Range("l1"))
 Worksheets("Sheet1").Shapes(13).Fill _
 .ForeColor.RGB = RGB(Range("m1"), 255 - Range("m1"), 255 + Range("m1"))
 Worksheets("Sheet1").Shapes(14).Fill _
 .ForeColor.RGB = RGB(Range("n1"), 255 - Range("n1"), 255 + Range("n1"))
 Worksheets("Sheet1").Shapes(15).Fill _
 .ForeColor.RGB = RGB(Range("o1"), 255 - Range("o1"), 255 + Range("o1"))
 Worksheets("Sheet1").Shapes(16).Fill _
 .ForeColor.RGB = RGB(Range("p1"), 255 - Range("p1"), 255 + Range("p1"))
 Worksheets("Sheet1").Shapes(17).Fill _
 .ForeColor.RGB = RGB(Range("q1"), 255 - Range("q1"), 255 + Range("q1"))
End Sub

【52322】Re:図を作って色分け…お急ぎ頂けると光...
発言  yata E-MAIL  - 07/11/8(木) 21:24 -

引用なし
パスワード
   yasuさん こんばんは

>続いて、色をつけるということをしたいのですが、
>もうちょっとかんたんにはならないでしょうか??
>
>あと、255±Range や 0±Range といった値が255を超える
>または0を下回った際には255、0にするというようにするには
>どうしたらよいでしょうか??
>
こんなことでいいですか?

Sub 色()
Dim 赤 As Long, 緑 As Long, 青 As Long
Dim aka As Long, midori As Long, ao As Long
Dim i As Integer

For i = 1 To 17
  'セルA1からQ1までの数値を調べて、補正した数値を変数aka,midori,ao に格納する
  Set Rng = Cells(1, i)
  
 赤 = Rng.Value
 緑 = 255 - Rng.Value
 青 = 255 + Rng.Value

 aka = Hosei(赤)
 midori = Hosei(緑)
 ao = Hosei(青)
'オートシェープを順番に1つづつ塗りつぶす。
 ActiveSheet.Shapes(i).Fill.ForeColor.RGB = RGB(aka, midori, ao)

Next i
End Sub

Function Hosei(ByVal num As Long) As Long
  Select Case num
    Case Is >= 255
      Hosei = 255
    Case Is <= 0
      Hosei = 0
    Case Else
      Hosei = num
  End Select
End Function

5161 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free