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

Question

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

keithin · Accepted Answer

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

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

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

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

keithin · Answer

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

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

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

jcctaira · Answer

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

Zi-co · Answer

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

参考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

Zi-co · Answer

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

参考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%

jcctaira · Answer

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

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

keithin · Answer

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

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

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

O_O · Answer

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

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

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

どうでしょうか。

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

肝心の使い方を書いてませんでした。

この回答への補足

＞試してみたのですが、同じ行にあるテキストボックスが消えてしまいます。

図形を消すのを線だけにすれば良いと思います。

あれ！開かない

参考出品（グラフです）

下記のマクロを作成しました。

この回答への補足

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

4行と5行の間に1行加えて、条件付き書式を使って、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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