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

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

投稿日時 - 2010-06-06 17:07:07

QNo.5949136

困ってます

質問者が選んだベストアンサー

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


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


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



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

投稿日時 - 2010-06-07 23:40:03

補足

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

投稿日時 - 2010-06-08 00:46:37

ANo.6

このQ&Aは役に立ちましたか?

10人が「このQ&Aが役に立った」と投票しています

[  前へ  |  次へ ]

ベストアンサー以外の回答(7件中 1~7件目)

ANo.8

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

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

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

投稿日時 - 2010-06-08 02:38:44

お礼

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

投稿日時 - 2010-06-09 00:36:11

ANo.7

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

投稿日時 - 2010-06-07 23:40:47

お礼

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

投稿日時 - 2010-06-09 00:32:18

ANo.5

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

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

投稿日時 - 2010-06-06 21:36:51

お礼

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

投稿日時 - 2010-06-07 22:29:27

ANo.4

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

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

投稿日時 - 2010-06-06 20:33:12

ANo.3

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

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

投稿日時 - 2010-06-06 20:18:26

補足

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

投稿日時 - 2010-06-07 22:43:36

お礼

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

投稿日時 - 2010-06-09 00:26:53

ANo.2

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

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


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

投稿日時 - 2010-06-06 20:09:24

お礼

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

投稿日時 - 2010-06-07 22:20:33

ANo.1

O_O

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

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

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

どうでしょうか。

投稿日時 - 2010-06-06 17:16:59

お礼

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

投稿日時 - 2010-06-07 22:12:39

あなたにおすすめの質問

[PR] お役立ち情報