【Excel】スケジュール表 進捗率を入れると帯を描写するマクロ

質問

【Excel】スケジュール表　進捗率を入れると帯を描写するマクロ
スケジュール表へ開始日と終了日を入力することで、その期間が"■"で表示される表があります。
この表へ進捗率を入力することで、開始日を基準に帯を表示させたいです。
進捗率が更新されたら、帯の長さ表示も更新されるように。
ご教授、宜しくお願いいたします。

回答No.6

keithin · ベストアンサー

肝心の使い方を書いてませんでした。失礼しました。
進捗率の数字を記入すると自動で帯を引きます。
複数セルに一度に記入・編集しても構いません。ただし進捗率を生数字を記入している前提です。数式で実は進捗率を計算させていたときは，このマクロは使えません。

それとコードを一カ所（実際は２カ所）直します。そういえば前のご質問でテキストボックスを使っていたのは残します。前回の回答のコードを削除し，下記をコピー貼り付け直します。コードを記入するシートの呼び出し方を，回答した手順と違うやり方でやって間違えないよう注意して操作してください。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim h As Range
　Dim ha As Range
　Dim hs As Range
　Dim s As object
　Set hs = Application.Intersect(Target, Range("D4:D9"))
　If hs Is Nothing Then Exit Sub

　For Each ha In hs.Areas
　　For Each h In ha
　　　For Each s In ActiveSheet.rectangles
　　　　If s.TopLeftCell.Row = h.Row Then s.Delete
　　　Next s
　　　If h > 0 Then
　　　ActiveSheet.Shapes.AddShape _
　　　　Type:=msoShapeRectangle, _
　　　　Left:=h.Offset(0, 1 + h.Offset(0, -2) - Range("B2")).Left, _
　　　　Top:=h.Top + h.Height / 2, _
　　　　Width:=h.Offset(0, 1 + h.Offset(0, -2) - Range("B2")).Resize(1, 1 + h.Offset(0, -1) - h.Offset(0, -2)).Width * h / 100, _
　　　　Height:=h.Height / 2
　　　End If
　　Next
　Next
End Sub

＃またご利用のソフトのバージョンをご質問に書いていません。マクロが動かない原因になるので，今度こそは忘れないようになさってください。

補足

ソフトのバージョン記入、失念しておりました（Excel　2007）。確かに動かないことがありますね。
試してみたのですが、同じ行にあるテキストボックスが消えてしまいます。
残すことができないでしょうか。

回答No.8

keithin

＞試してみたのですが、同じ行にあるテキストボックスが消えてしまいます。
＞残すことができないでしょうか。

本当に間違いなく改訂版のマクロを試して，それでテキストボックスが消えたのですか？

もし間違いなくそうなのでしたら，あなたがいま使っている「テキストボックスの追加」は，以前のご相談で見ていたマクロと違いますね。
その場合は最初のご相談でお話ししておいたように，既存のマクロとすり合わせて全体としての調整が必要です。情報が足りませんので，残念ながら適切なアドバイスは出来ません。

お礼

私のコピーミスでした。申し訳ございません。m(__)m
やりたかったことができそうです。
ありがとうございました。

回答No.7

jcctaira

図形を消すのを線だけにすれば良いと思います。
「If .Shapes(I).Type = msoLine」で判断するように訂正して下さい（☆の行）。

　　　For I = .Shapes.Count To 1 Step -1
☆　　　　If .Shapes(I).Type = msoLine Then .Shapes(I).Delete
　　　Next I

お礼

早速のご回答、ありがとうございます。
大変参考になりました。^_^

回答No.5

Zi-co

あれ！開かない
では、こちらを

参考URL：

http://dl6.getuploader.com/g/1%7Ctaka816jp/53/%E4%BD%9C%E6%A5%AD%E6%99%82%E9%96%93%E3%81%A8%E9%80%B2%E6%8D%97%E7%8E%87.J

お礼

ご回答ありがとうございます。
おっ！どこかで見たような、、、
このような進捗率の出し方もありますね。
参考になります。

回答No.4

Zi-co

参考出品（グラフです）
日・祝のみ考慮に入れてます

参考URL：

http://www.excel.studio-kazu.jp/mwiki/images/0/09/%E4%BD%9C%E6%A5%AD%E6%99%82%E9%96%93%E3%81%A8%E9%80%B2%E6%8D%97%E7%8E%

回答No.3

jcctaira

下記のマクロを作成しました。
ボタン等で実行するようにして下さい。

1.最初にシェープ（線）をすべて消しています。
2.開始日は考慮しています。作業工程表示開始日が6/6 で　工程開始が6/4　等々
3.終了日は考慮していませんので、工程日数分線が引かれてしまいます。
4.線を引くためにE列～は全て列幅を同じにして下さい。
5.線の太さ・色・線種・縦位置は随時変更して下さい。

Sub ライン表示()
　With ActiveSheet
　　　For I = .Shapes.Count To 1 Step -1
　　　　　.Shapes(I).Delete
　　　Next I

　　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　　For 行 = 4 To 最終行
　　　　　日数 = Cells(行, "C") - Cells(行, "B") + 1
　　　　　進捗日数 = 日数 * Cells(行, "D") / 100
　　　　　Select Case True
　　　　　　　Case Range("B2") <= Cells(行, "B")
　　　　　　　　　開始列 = Cells(行, "B") - Range("B2")
　　　　　　　Case Else
　　　　　　　　　開始列 = 0
　　　　　　　　　進捗日数 = 進捗日数 - (Range("B2") - Cells(行, "B"))
　　　　　End Select
　　　　　If 進捗日数 > 0 Then
　　　　　　　縦位置 = Cells(行 + 1, "E").Top - 4
　　　　　　　横位置 = Cells(行, "E").Offset(0, 開始列).Left
　　　　　　　横幅 = Cells(行, "E").Width * 進捗日数
　　　　　　　.Shapes.AddLine(横位置, 縦位置, 横位置 + 横幅, 縦位置).Select
　　　　　　　Selection.ShapeRange.Line.Weight = 4
　　　　　　　Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
　　　　　End If
　　　Next 行
　End With
End Sub

お礼

素人の私でも解りやすいマクロで書いていただきありがとうございます。
大変勉強になりました。

補足

ご回答ありがとうございます。まさにやりたかったことです。
最初に線を消しますが、描いた線のみを消すことができないでしょうか。
サンプル画像にはありませんが、■が表示されるエリア部分にテキストボックスでコメントを表示し、残したく思います。

回答No.2

keithin

シート名タブを右クリックしてコードの表示を選び，現れたシートに下記のようにコピー貼り付ける。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim h As Range
　Dim ha As Range
　Dim hs As Range
　Dim s As Shape
　Set hs = Application.Intersect(Target, Range("D4:D9"))
　If hs Is Nothing Then Exit Sub

　For Each ha In hs.Areas
　　For Each h In ha
　　　For Each s In ActiveSheet.Shapes
　　　　If s.TopLeftCell.Row = h.Row Then s.Delete
　　　Next s
　　　If h > 0 Then
　　　ActiveSheet.Shapes.AddShape _
　　　　Type:=msoShapeRectangle, _
　　　　Left:=h.Offset(0, 1 + h.Offset(0, -2) - Range("B2")).Left, _
　　　　Top:=h.Top + h.Height / 2, _
　　　　Width:=h.Offset(0, 1 + h.Offset(0, -2) - Range("B2")).Resize(1, 1 + h.Offset(0, -1) - h.Offset(0, -2)).Width * h / 100, _
　　　　Height:=h.Height / 2
　　　End If
　　Next
　Next
End Sub

＃いま現在あなたが他に運用しているマクロ？と，色々調整がいるかもしれません。
そういった微調整を含めエラー対策等も特に施していませんので，もう少し実際の様子に合わせて調整してから使ってください。
再作成の依頼はご容赦方。

お礼

いつもありがとうござます。
確かに色々と調整が必要と感じております。
また宜しくお願いいたします。

回答No.1

O_O

4行と5行の間に1行加えて、条件付き書式を使って、
その上のセルに"■"が入ったなら塗りつぶし色のパターン（例えば緑とか）を表示させるというように
すればできるかもしれませんね。

条件付き書式
数式=E4="■" 書式押して、パターンを押して「緑」を選択。

さらに、帯みたくするために、新たに加えた行の高さを低くする。

どうでしょうか。

お礼

ご回答ありがとうございます。
参考にさせていただきます。
また宜しくお願いいたします。