[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『工程表の進捗線をオートシェイプの矢印で表示させたい。。』（きらり）
いつも参考にさせていただいております。
過去ログ検索して類似するものを見つけることがでませんでしたので、、
質問させて下さい。
A B C D(品名) E(個数) F(開始日) G(終了日) H I J K L M 3 1 2 3 ・・・ 4 火 水 木 ・・・ 5 AM PM AM PM AM PM ・・・ 6 あああ 1 8/1AM 8/2PM →→→→→→→→ 7 いいい 3 8/2PM 8/3AM →→→→ 8 ううう 5 以下200行あります。 H列、I列は、結合して日付と曜日を表示していて、1日〜31日まで続いてます。J列・K列、L列・M列･･･も同様です。 日付は、数字の1 2 3を入力しているだけで曜日はDATE関数で表示しています。 月の表示は、同じｼｰﾄのB列2行目に 8 (月) と表示しています。 年の表示は、別シート「メニュー」のB列10行目に 2009 と表示しています。
上記のような工程表を作成しました。
F列(開始日)に 8/1AM 、G列(終了日)に 8/2PM というように日付とAM or PMを入力したら自動的にH列の1日AMのセルからK列の2日PMのセルまでというようにオートシェィプの矢印が出るように表示させたいと思っています。
上記の表でH列6行目〜M列8行目(矢印を表示させる範囲)のセルには必要事項を入力したいので、この範囲に関数で矢印を表示させるよりは、オートシェイプの矢印を表示させたいと考えています。
このように設定をするのは可能でしょうか？
もし可能であれば、設定するにはどういうマクロを記述しないといけないのでしょうか？？
どなたかご教示をお願い致します。
ガントチャート エクセル でググッてみたら、こんなページがありました。 http://mizhiro.mitelog.jp/myproject/2006/12/excel_7024.html (ROUGE)
ありがとうございます。
早速、教えていただいたページを見てみました。
日付を入力したら、オートシェイプが伸び縮みしているのをみて感動しました。
やはりこういう設定はできるんですね。
この操作を自作の表に展開するのはやはり困難なことなのでしょうか。。
ご教示ありがとうございました。
(きらり)
> この操作を自作の表に展開するのはやはり困難なことなのでしょうか。。 そういったマクロを自作すればいけると思います。 とはいっても、MSProjectを使うほうが楽チンです。 (ROUGE)
以前、私もガンチャートをＶＢＡで作ったことがありました。
新規ブック（Sheet1、Sheet2というシ−トがあるブック）にて試してみてください。
まず、サンプルデータの作成
標準モジュールに
'=====================================================================
Option Explicit
Sub サンプルシート作成()
Dim g0 As Long
With ActiveSheet
.Range("a2").Value = 2009
.Range("b2").Value = 8
.Range("d5:g5").Value = [{"品名","個数","開始日","終了日"}]
.Range("d6:g6").Value = [{"あああ",1,"2009/8/1","2009/8/2 12:00:00"}]
.Range("d7:g7").Value = [{"いいい",3,"2009/8/2","2009/8/3"}]
.Range("d8:g8").Value = [{"ううう",5,"2009/8/3","2009/8/10 12:00:00"}]
.Range("f:g").NumberFormatLocal = "[$-409]m/d AM/PM;@"
For g0 = 8 To 68 Step 2
.Range(.Cells(3, g0), .Cells(3, g0 + 1)).MergeCells = True
.Range(.Cells(3, g0), .Cells(3, g0 + 1)).Value = (g0 - 6) / 2
.Range(.Cells(4, g0), .Cells(4, g0 + 1)).MergeCells = True
.Range(.Cells(4, g0), .Cells(4, g0 + 1)).NumberFormatLocal = "aaa"
.Range(.Cells(5, g0), .Cells(5, g0 + 1)).Value = Array("am", "pm")
Next
.Range(.Cells(4, 8), .Cells(4, 68)).Formula = "=DATE($a$2,$B$2,H3)"
.Range("h3:bq5").HorizontalAlignment = xlCenter
End With
End Sub
Sheet1をアクティブにして、上記のサンプルシート作成を実行してみてください。 きらりさんが投稿されたようなシートを作成しました。 尚、年は同じシートのＡ２に入力されています。 又、Ｆ列、Ｇ列の日付は、書式設定で表示されていますから、 実際のデータがどのようなもので ＡＭ／ＰＭを区別しているかＦ列、Ｇ列のデータと書式をよく調べてください。
これがわかれば、セルD9からデータを追加してもよいです。
では、チャート作成コードです。 サンプルシート作成 とは別の標準モジュールに
'==============================================================================
Const hh = 5 '目盛り列の巾数
Sub main()
Dim idx As Long
Dim rw As Long
Dim svrw As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim cl As Long '四角の色
Dim eventno As Variant
Dim shpnm As String
With ActiveSheet
.Columns("a:g").ColumnWidth = 10
.Columns("h:bq").ColumnWidth = hh
Call open_scale(8, 70, hh, .Columns("h").Width)
idx = 6
svrw = 0
Do Until .Cells(idx, 4).Value = ""
rw = idx
wk = .Cells(idx, 7).Value - .Cells(idx, 6).Value + 0.5
st = (.Cells(idx, 6).Value - #8/1/2009#) * hh * 2
Set shp = mk_rectangle(Rows(rw), st, wk * hh * 2)
shpnm = "shp" & idx
eventno = .Cells(idx, 4).Value
With shp
.Name = shpnm
.TextFrame.Characters.Text = eventno
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.SchemeColor = 3
.Fill.Transparency = 0.75
End With
idx = idx + 1
Loop
End With
End Sub
別の標準モジュールに既作のガンチャート作成モジュールパック
'=================================================================
Option Explicit
Private st_col As Single
Private st_point As Single
Private myscale As Single
Private sswidth As Single
Private mentwidth As Double
Sub open_scale(開始列, 開始列までのセル巾, 目盛り巾, 目盛りPnt, Optional sht As Worksheet)
' チャート作成するシート情報を登録する
' input : 開始列 --チャート作成開始列
' 開始列までのセル巾--- 列幅の合計値
' 目盛り巾------------目盛りとなる列の列幅
' 目盛りPnt-----------目盛りとなる列のWidth
st_col = 開始列
st_point = 開始列までのセル巾
myscale = 目盛り巾
sswidth = 目盛りPnt
If sht Is Nothing Then Set sht = ActiveSheet
With sht.Next
.Columns("a").ColumnWidth = 12
.Columns("b:c").ColumnWidth = 6
mentwidth = .Range("b1:c1").Width - .Range("a1").Width
End With
End Sub
'=================================================================
Function mk_rectangle(rng As Range, 開始 As Single, 巾 As Single, Optional sht As Worksheet = Nothing) As Shape
'指定された行に開始位置，巾の情報から、チャートを作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' sht----チャートを作成するシートオブジェクト 尚、このシートの右のシートは作業シートとして
' 使用します。
' txtstr----チャートに記述する文字列
'output : mk_rectangle----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkwidth As Single
Dim wk As Single
Dim wk2 As Single
Dim ha As Single
Dim ha2 As Single
Dim cnv_left As Single
Dim cnv_width As Single
If sht Is Nothing Then Set sht = ActiveSheet
wk = Int(開始 / myscale) * myscale
wk2 = (開始 - wk) / myscale
ha = Int(巾 / myscale) * myscale
ha2 = (巾 - ha) / myscale
cnv_left = get_point(wk + st_point, sht.Next)
cnv_width = get_point(ha, sht.Next)
If wk2 = 0 Then
mkleft = cnv_left + mentwidth * (st_col - 1 + Int((開始 - 0.1) / myscale))
Else
mkleft = cnv_left + mentwidth * (st_col - 1 + Int((wk - 0.1) / myscale)) + sswidth * wk2
End If
If ha2 = 0 Then
If ha = 0 Then
mkwidth = cnv_width
Else
mkwidth = cnv_width + mentwidth * Int((ha - 0.1) / myscale)
End If
Else
If ha = 0 Then
mkwidth = cnv_width + sswidth * ha2
Else
mkwidth = cnv_width + mentwidth * Int((ha - 0.1) / myscale) + sswidth * ha2
End If
End If
With rng
Set mk_rectangle = sht.Shapes.AddShape(msoShapeRectangle, mkleft, .Top, mkwidth, .Height)
End With
End Function
'=================================================================
Function get_point(セル幅, sht As Worksheet)
With sht
.Cells(1, 1).ColumnWidth = セル幅
get_point = IIf(.Cells(1, 1).Width <= 0, 0, .Cells(1, 1).Width)
End With
End Function
サンプルのあるSheet1をアクティブにしてmainを実行してみてください。 矢印ではなく、四角形ですが、作成されると思います。
*尚、Sheet2は、プログラムが作業シートとして使っていますから、注意してください。
四角形を矢印に代えるのは、やってみてください。
まずは、上記コードの作動を確認してください。
ichinose
MSProject、、名前だけ聞いたことがあります。
使用用途によって色々なソフトがあるんですね。
マクロを自作したら大丈夫なんですね。。
それにはマクロに対する知識も必要ですもんね。
私は、今まで主に関数を使用して集計表などを作成して
きたのですが、やっぱりマクロの勉強も必要だと感じています。
これからマクロの勉強もがんばりたいと思います。
ありがとうございます。
（きらり）
コードを組んでいただいてありがとうございます。
教えていただいた内容を早速今から実行してみようと思います。
上記のような本格的なＶＢＡを扱うのは初めてですので、、
行き詰るかと思いますので、その時はまた教えていただいてもよろしいでしょうか。。
今からやってみます。。
ご教示ありがとうございました。
（きらり）
上記のマクロを新規ブックで実行してみたところ出来ました。
本当にありがとうございます。
このコードを元にセルの列幅を変えてみたんですが、、
どうしてもマクロ実行が中断されてしまいます。
Const hh = 5 '目盛り列の巾数 ←このマクロのコードの中を下記のようにセル幅を変更させてみました。
.Columns("a").ColumnWidth = hh
.Columns("b:c").ColumnWidth = 15
.Columns("d").ColumnWidth = 20
.Columns("e").ColumnWidth = 7
.Columns("f:g").ColumnWidth = 9
.Columns("h:bq").ColumnWidth = hh
Function get_point(セル幅, sht As Worksheet) ←このマクロコードの中の
.Cells(1, 1).ColumnWidth = セル幅 ←この文章が黄色に囲まれてマクロ実行が中断されてしまいます。
どう対処したらよろしいでしょうか？？
（きらり）
ん？確かに列幅を変更しただけでは、正しい処理はしません。 が、エラーにはなりませんでしたけどね！！ データを変えたのですか？
ガンチャートを実際に作成しているのは、ガンチャート作成モジュールパックというプログラムです。 列の変更をこのプログラムに教えてあげないと正常には作動しません。 もっともそのようにmainを作成しなかった私にも拡張性に欠いたプログラムという問題がありました。
以下のようにmainのみを変更してください。
Option Explicit
'==============================================================================
Const hh = 5 '目盛り列の巾数
Sub main()
Dim idx As Long
Dim rw As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim cl As Long '四角の色
Dim eventno As Variant
Dim shpnm As String
Dim sumwidth As Single
With ActiveSheet
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
.Columns("a").ColumnWidth = hh
.Columns("b:c").ColumnWidth = 15
.Columns("d").ColumnWidth = 20
.Columns("e").ColumnWidth = 7
.Columns("f:g").ColumnWidth = 9
.Columns("h:bq").ColumnWidth = hh
For idx = 1 To 7
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
Call open_scale(8, sumwidth, hh, .Columns("h").Width)
idx = 6
Do Until .Cells(idx, 4).Value = ""
rw = idx
wk = .Cells(idx, 7).Value - .Cells(idx, 6).Value + 0.5
st = (.Cells(idx, 6).Value - #8/1/2009#) * hh * 2
Set shp = mk_rectangle(Rows(rw), st, wk * hh * 2)
shpnm = "shp" & idx
eventno = .Cells(idx, 4).Value
With shp
.Name = shpnm
.TextFrame.Characters.Text = eventno
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.SchemeColor = 3
.Fill.Transparency = 0.75
End With
idx = idx + 1
Loop
End With
End Sub
他のプログラムも当然使いますよ！！
>Cells(1, 1).ColumnWidth = セル幅 ←この文章が黄色に囲まれてマクロ実行が中断されてしまいます。 因みにどんなエラーメッセージですか？
ichinose
修正のプログラムどうもありがとうございました。
プログラムは全体に指示が影響するんですね。
一部を変更しても正常には処理しないということなんですねっ。
勉強になります。。
A列、B列、C列の列幅を少しだけ広げようと思ってやってみたのですが、、
うまくいきませんでした。。(汗) 欲張りすぎました。。
今から修正していただいたコードを使用してみようと思います。
中断されたエラーメッセージは、
「このコマンドを使用するとデバックは中断します」と出ました。
色々教えて頂いて感謝しております。
今からまたトライしてみます。
ご教示ありがとうございました。
（きらり）
列幅を変更するコードを登録したところ、無事に列幅が変更されました。
マクロ実行後、緑の四角形も右向きの矢印に変更することも出来ました。。(嬉)
sht.Shapes.AddShape(msoShapeRectangle, mkleft, .Top, mkwidth, .Height)のコードを、、
sht.Shapes.AddShape(msoShapeRightArrow, mkleft, .Top, mkwidth, .Height)に変更しました。
日付を入力したら、ＡＭ ＰＭ まで判断されて矢印が表示されますし、矢印の中に品名までもが
表示されていてとても見やすい工程表になりました。
これからたくさん活用していこうと思います。
すごく勉強になりました。
ありがとうございました。
すみません、、あと２つ質問してもよろしいでしょうか？？
ひとつ目が、、オートシェイプの四角形の図形（今は右向きの矢印ですが)を「図形描画」の直線の矢印に変更するには、、
四角形から右向き矢印に変更したように図形の種類のコードを変更するだけではダメなんですよね？？
Shapes.AddLine(始点列.始点行, 終点列, 終点行) に当てはめて変更しないといけないんでしょうか？？
そうした場合、ichinoseさんから教えて頂いたコードのどの部分を変更すれば直線の矢印に変更されるのでしょうか？？
sht.Shapes.AddShape(msoShapeRectangle, mkleft, .Top, mkwidth, .Height)このコードの上に書かれているコードも変更しないといけないのでしょうか？？
（変更理由は、通常使用する工程表（これは右向き矢印の工程表を使用します）とは別にもう一枚、機械別に全工程名を表示させた工程表がありまして、非常に詳細な為、出来ることならそれは細い矢印の方を用いたいと思いまして、、）
ふたつ目が、、、「図形描画」の直線の矢印にした場合、矢印の表示位置を行の高さの半分よりもう少し上に表示されるように設定するにはどうしたらよいでしょうか？？
質問ばかりで大変、申し訳ありません。
お時間がありましたら、ご教示お願い致します。
（きらり）
投稿したコードの「ガンチャート作成モジュールパック」と呼んでいるコードは、このサイトと同様の 掲示板サイトの御質問のためにだいぶ前に作成したものです。作りはじめ（初版）が2003/12/で 2005/6に改訂し、2006/5に更に改訂していたみたいです。 私の仕事にも一度使いました。 掲示板での質問に回答するために作ったコードのおかげで自分の仕事では、時間をかけずに ガンチャートを作成することが出来ています。
今回、きらりさんの御質問のおかげで更に機能追加や修正をすることができました。 ガンチャートなんて仕様は中々ないのでこういう機会でもないと機能追加もしないので・・・。
もう一度、長くなるけど全部投稿します。
新規ブック（Sheet1、Sheet2というシ−トがあるブック）にて試してみてください。 まず、サンプルデータの作成
標準モジュールに
'=====================================================================
Option Explicit
Sub サンプルシート作成()
Dim g0 As Long
With ActiveSheet
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
.Range("a2").Value = 2009
.Range("b2").Value = 8
.Range("d5:g5").Value = [{"品名","個数","開始日","終了日"}]
.Range("d6:g6").Value = [{"あああ",1,"2009/8/1","2009/8/2 12:00:00"}]
.Range("d7:g7").Value = [{"いいい",3,"2009/8/2","2009/8/3"}]
.Range("d8:g8").Value = [{"ううう",5,"2009/8/3","2009/8/10 12:00:00"}]
.Range("f:g").NumberFormatLocal = "[$-409]m/d AM/PM;@"
For g0 = 8 To 68 Step 2
.Range(.Cells(3, g0), .Cells(3, g0 + 1)).MergeCells = True
.Range(.Cells(3, g0), .Cells(3, g0 + 1)).Value = (g0 - 6) / 2
.Range(.Cells(4, g0), .Cells(4, g0 + 1)).MergeCells = True
.Range(.Cells(4, g0), .Cells(4, g0 + 1)).NumberFormatLocal = "aaa"
.Range(.Cells(5, g0), .Cells(5, g0 + 1)).Value = Array("am", "pm")
Next
.Range(.Cells(4, 8), .Cells(4, 68)).Formula = "=DATE($a$2,$B$2,H3)"
.Range("h3:bq5").HorizontalAlignment = xlCenter
End With
End Sub
Sheet1をアクティブにして、上記のサンプルシート作成を実行してみてください。 きらりさんが投稿されたようなシートを作成しました。 尚、年は同じシートのＡ２に入力されています(月は、セルＢ２）。 又、Ｆ列、Ｇ列の日付は、書式設定で表示されていますから、 実際のデータがどのようなもので ＡＭ／ＰＭを区別しているかＦ列、Ｇ列のデータと書式をよく調べてください。
別の標準モジュールに機能追加したガンチャート作成モジュールパック
'=============================================================================
Private st_col As Single
Private st_point As Single
Private myscale As Single
Private sswidth As Single
Private mentwidth As Double
'=============================================================================
Sub open_scale(開始列, 開始列までのセル巾, 目盛り巾, 目盛りPnt, Optional sht As Worksheet)
' チャート作成するシート情報を登録する
' input : 開始列 --チャート作成開始列
' 開始列までのセル巾--- 列幅の合計値
' 目盛り巾------------目盛りとなる列の列幅
' 目盛りPnt-----------目盛りとなる列のWidth
st_col = 開始列
st_point = 開始列までのセル巾
myscale = 目盛り巾
sswidth = 目盛りPnt
If sht Is Nothing Then Set sht = ActiveSheet
With sht.Next
.Columns("a").ColumnWidth = 12
.Columns("b:c").ColumnWidth = 6
mentwidth = .Range("b1:c1").Width - .Range("a1").Width
End With
End Sub
'=============================================================================
Function mk_shape(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, Optional s_type As MsoAutoShapeType = msoShapeRectangle, Optional ByVal sht As Worksheet = Nothing) As Shape
'指定された行に開始位置，巾の情報から、チャートを作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' s_type--作成するオートシェイプの種類（MsoAutoShapeType クラスの定数に準拠）
' sht----チャートを作成するシートオブジェクト 尚、このシートの右のシートは作業シートとして
' 使用します。
'
'output : mk_shape----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkwidth As Single
Dim mk_inf As Variant
If sht Is Nothing Then Set sht = ActiveSheet
mk_inf = get_mk_locate_inf(rng, 開始, 巾, sht)
mkleft = mk_inf(1)
mkwidth = mk_inf(2)
With rng
Set mk_shape = sht.Shapes.AddShape(s_type, mkleft, .Top, mkwidth, .Height)
End With
End Function
'=============================================================================
Function mk_line(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, Optional ByVal t_rate As Long = 50, Optional ByVal sht As Worksheet = Nothing) As Shape
'指定された行に開始位置，巾の情報から、チャート(ライン）を作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' ｔ_rate----ラインを作成する高さ（top）位置をRng.heghtの割合でRng.Top位置から作成する（0〜100）
' 例 rngとしてRange("A1")、t_rateとして、20が指定された場合
' range("a1").top+range("a1").height*t_rate/100 がライン作成する縦位置となる
' sht----チャートを作成するシートオブジェクト 尚、このシートの右のシートは作業シートとして
' 使用します。
'output : mk_line----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkright As Single
Dim mk_inf As Variant
If sht Is Nothing Then Set sht = ActiveSheet
mk_inf = get_mk_locate_inf(rng, 開始, 巾, sht)
mkleft = mk_inf(1)
mkright = mk_inf(1) + mk_inf(2)
With rng
Set mk_line = sht.Shapes.AddLine(mkleft, .Top + .Height * t_rate / 100, mkright, .Top + .Height * t_rate / 100)
End With
End Function
'=============================================================================
Private Function get_mk_locate_inf(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, ByVal sht As Worksheet) As Variant
Dim mli(1 To 2) As Single
Dim wk As Single
Dim wk2 As Single
Dim ha As Single
Dim ha2 As Single
Dim cnv_left As Single
Dim cnv_width As Single
wk = Int(開始 / myscale) * myscale
wk2 = (開始 - wk) / myscale
ha = Int(巾 / myscale) * myscale
ha2 = (巾 - ha) / myscale
cnv_left = get_point(wk + st_point, sht.Next)
cnv_width = get_point(ha, sht.Next)
If wk2 = 0 Then
mli(1) = cnv_left + mentwidth * (st_col - 1 + Int((開始 - 0.1) / myscale))
Else
mli(1) = cnv_left + mentwidth * (st_col - 1 + Int((wk - 0.1) / myscale)) + sswidth * wk2
End If
If ha2 = 0 Then
If ha = 0 Then
mli(2) = cnv_width
Else
mli(2) = cnv_width + mentwidth * Int((ha - 0.1) / myscale)
End If
Else
If ha = 0 Then
mli(2) = cnv_width + sswidth * ha2
Else
mli(2) = cnv_width + mentwidth * Int((ha - 0.1) / myscale) + sswidth * ha2
End If
End If
get_mk_locate_inf = mli()
Erase mli()
End Function
'=============================================================================
Private Function get_point(セル幅, sht As Worksheet)
With sht
.Cells(1, 1).ColumnWidth = セル幅
get_point = IIf(.Cells(1, 1).Width <= 0, 0, .Cells(1, 1).Width)
End With
End Function
別のモジュールにチャート要素の形態を四角形、矢印、直線（矢印）で作成したコード
'==============================================================================
'==============================================================================
Const hh = 5 '目盛り列の巾数
Const ss = 8 'チャート開始列
Sub main1() 'チャートの要素を四角形
Dim idx As Long
Dim rw As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim cl As Long '四角の色
Dim eventno As Variant
Dim shpnm As String
Dim sumwidth As Single
With ActiveSheet
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
.Columns("a").ColumnWidth = hh
.Columns("b:c").ColumnWidth = 15
.Columns("d").ColumnWidth = 20
.Columns("e").ColumnWidth = 7
.Columns("f:g").ColumnWidth = 8
.Columns("h:bq").ColumnWidth = hh
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
Call open_scale(ss, sumwidth, hh, .Columns("h").Width)
idx = 6
Do Until .Cells(idx, 4).Value = ""
rw = idx
wk = .Cells(idx, 7).Value - .Cells(idx, 6).Value + 0.5
st = (.Cells(idx, 6).Value - DateSerial(.Range("a2").Value, .Range("b2").Value, 1)) * hh * 2
Set shp = mk_shape(Rows(rw), st, wk * hh * 2)
shpnm = "shp" & idx
eventno = .Cells(idx, 4).Value
With shp
.Name = shpnm
.TextFrame.Characters.Text = eventno
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.SchemeColor = 3
.Fill.Transparency = 0.75
End With
idx = idx + 1
Loop
End With
End Sub
'======================================================================================
Sub main2() 'チャート要素をオ−トシェイプの矢印
Dim idx As Long
Dim rw As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim cl As Long '矢印の色
Dim eventno As Variant
Dim shpnm As String
Dim sumwidth As Single
With ActiveSheet
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
.Columns("a").ColumnWidth = hh
.Columns("b:c").ColumnWidth = 15
.Columns("d").ColumnWidth = 20
.Columns("e").ColumnWidth = 7
.Columns("f:g").ColumnWidth = 8
.Columns("h:bq").ColumnWidth = hh
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
Call open_scale(ss, sumwidth, hh, .Columns("h").Width)
idx = 6
Do Until .Cells(idx, 4).Value = ""
rw = idx
wk = .Cells(idx, 7).Value - .Cells(idx, 6).Value + 0.5
st = (.Cells(idx, 6).Value - DateSerial(.Range("a2").Value, .Range("b2").Value, 1)) * hh * 2
Set shp = mk_shape(Rows(rw), st, wk * hh * 2, msoShapeRightArrowCallout)
shpnm = "shp" & idx
eventno = .Cells(idx, 4).Value
With shp
.Name = shpnm
.TextFrame.Characters.Text = eventno
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.SchemeColor = 3
.Fill.Transparency = 0.75
End With
idx = idx + 1
Loop
End With
End Sub
'=================================================================================
Sub main3() '直線の矢印
Dim idx As Long
Dim rw As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim shpnm As String
Dim sumwidth As Single
With ActiveSheet
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
.Columns("a").ColumnWidth = hh
.Columns("b:c").ColumnWidth = 15
.Columns("d").ColumnWidth = 20
.Columns("e").ColumnWidth = 7
.Columns("f:g").ColumnWidth = 8
.Columns("h:bq").ColumnWidth = hh
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
Call open_scale(ss, sumwidth, hh, .Columns("h").Width)
idx = 6
Do Until .Cells(idx, 4).Value = ""
rw = idx
wk = .Cells(idx, 7).Value - .Cells(idx, 6).Value + 0.5
st = (.Cells(idx, 6).Value - DateSerial(.Range("a2").Value, .Range("b2").Value, 1)) * hh * 2
Set shp = mk_line(Rows(rw), st, wk * hh * 2, 35)
' ↑上の行の35という数値を大きくすれば、行の下方に
' 小さくすれば、行の上方に矢印が作成されます。（0〜100）
shpnm = "shp" & idx
With shp
.Name = shpnm
.Fill.ForeColor.SchemeColor = 3
.Fill.Transparency = 0.75
.Line.BeginArrowheadLength = msoArrowheadLengthMedium
.Line.BeginArrowheadWidth = msoArrowheadWidthMedium
.Line.BeginArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
End With
idx = idx + 1
Loop
End With
End Sub
以上です。 main1からmain3を実行して作成されるチャートの形態を確認してください。 御質問の回答にあたるのはmain3になります。
尚、main1とmain2は、実は、
Set shp = mk_shape(Rows(rw), st, wk * hh * 2) 'main1
と言うコードをちょこっと変更（パラメータを追加）しただけで他は全く同じなんです。
Set shp = mk_shape(Rows(rw), st, wk * hh * 2, msoShapeRightArrowCallout) 'main2
機能追加の大きな箇所はチャート形態をパラメータ一つで変更可能にしたことです。 ライン（直線）は、悩みましたが、別のインターフェースで作成することにしました。
こういうの作っておくと自分の仕事で要件定義時に
クライアント： ガンチャートなんて簡単にできるのですか？
私 : そんなの3分でできます（自信たっぷり、得意満面）
なんてことになります。これで契約成立（もっともあまりに自信たっぷりだと 後でこけますけど・・）。
ということで 2009/8/29 機能追加
ichinose
こんにちは。
追加質問にまでご丁寧に回答いただきまして、、
本当にありがとうございます。。
ichinoseさんのご指導があったからこそ、、
今回の工程表がスムーズに作成できていると思っています。
それと同時にエクセルってホント奥深いもので、、
可能性をたくさん秘めているいいソフトだと、
改めて痛感しました。
私も今から自分なりにマクロの勉強をしていきたいと思います。
今回の事が私にとっていい経験になったし、
まだまだ勉強しないといけないことがたくさんあるんだなぁって感じました。
出来上がりまであと少し!!
教えていただいたコードを使用させてもらって、
完成させたいと思います。
お忙しいところ何度もご回答いただいたことに深く感謝します。
本当にありがとうございます。
(きらり)
度々、質問ばかりで申し訳ありません。。（汗）
直線の矢印のコードを使用させて頂いて、コードをモジュールに貼り付け、、
マクロを実行させたところ、
Sub main3() '直線の矢印 ←この文章が黄色く囲われて、、
Set shp = mk_line(Rows(rw), st, wk * hh * 2, 35) ←このコードの mk_line が反転して、
「Sub または Function が定義されていません。」というメッセージが出て、
マクロが中断されてしまうのです。。（汗）
私の貼り付け方法が違ってますか？？
標準モジュールを追加して、そこに直線の矢印のコードをコピーして貼り付けているのですが、、
お時間があれば、教えていただけないでしょうか？？
（きらり）
直前の私の投稿の「機能追加したガンチャート作成モジュールパック」も差し替えてください。 機能追加していますから、これを差し替えないと 「Sub または Function が定義されていません。」というエラーがでます。
差し替えを行なわないとmain1,main2だって、同じエラーになるはずですよ！！ それから、行頭にある
Const hh = 5 '目盛り列の巾数 Const ss = 8 'チャート開始列
これも必要ですよ！！ 再度、確認してください。
ichinose
なるほど!!
そうことなんですねっ!!
わかりました。
やってみます。
ありがとうございます。
(きらり)
ichinoseさんの分かりやすいご指導のおかげで、、
無事、工程表が完成しました。
本当にありがとうございました。
私もマクロが使いこなせるように勉強して行きたいと思います。
( きらり )
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.