投稿2020/02/21 02:16
初心者ですが、VBAを用いて簡易的な進捗管理シートを作ろうと思っています。
概要としては、タスクと日付を入力し、開始日と終了日を事前に用意してあるカレンダー？上にバーとして表示する
よくあるものを作りたいと思っています。
エラーメッセージは出ていませんが、実行をしてもバーが描画されないといった状況です。 問題がどこなのかもよくわかっていません・・・
Option Explicit Private Sub cmdSuchedule_Click() Dim ws1 As Worksheet Dim i As Long Dim st1 As Range, en1 As Range Dim dayEnd1 As Long, rowEnd1 As Long Dim rngStart1 As Range, rngEnd1 As Range Dim xStart1 As Single, yStart1 As Single, xEnd1 As Single, x1 As Single, y1 As Single Set ws1 = ActiveSheet With ws1 dayEnd1 = .Cells(6, Columns.Count).End(xlToLeft).Column 'カレンダー上の最終日付列の取得 rowEnd1 = .Cells(Rows.Count, 4).End(xlUp).Row 'タスクの最終行の取得 On Error Resume Next For i = 8 To rowEnd1 If Cells(i, 5) <> "" And Cells(i, 6) <> "" Then '開始予定日と終了予定日の対応列を設定する Set st1 = .Cells(6, WorksheetFunction.Match(.Cells(i, 5), .Range(.Cells(6, 11), .Cells(6, dayEnd1)), 0)) '開始予定日のカレンダー上での対応列を設定 Set en1 = .Cells(6, WorksheetFunction.Match(.Cells(i, 6), .Range(.Cells(6, 11), .Cells(6, dayEnd1)), 0)) '終了予定日のカレンダー上での対応列を設定 '開始予定日と終了予定日の両方が見つかればバーを描画する Set rngStart1 = .Cells(i, st1.Column) 'バーの描画開始セルの設定 Set rngEnd1 = .Cells(i, en1.Column + 1) 'バーの描画終了セルの1日後を設定 xStart1 = rngStart1.Left 'バーの描画開始位置のX座標 yStart1 = rngStart1.Top + 4 'バーの描画開始位置のY座標 xEnd1 = rngEnd1.Left 'バーの描画終了位置のX座標 y1 = rngEnd1.Height - 70 'バーの高さ方向の幅 With .Shapes.AddShape(msoShapeRectangle, xStart1, yStart1, xEnd1 - xStart1, y1) 'オートシェイプでバーを追加 .Fill.ForeColor.RGB = RGB(255, 255, 255) 'バーの色を指定 .Line.ForeColor.RGB = RGB(0, 0, 0) '枠線の色を指定 End With End If Next i '次の行へ End With End Sub
ここに問題に対して試したことを記載してください。
ここにより詳細な情報を記載してください。
回答3件
0
大体原因はわかりました。
まずWorksheetFunction.Matchの使い方が間違っています。
恐らくMatchしたセルのアドレスが返されると想定されているようですがMatch範囲で指定した相対位置が返ります。
例で言うと範囲の開始位置であるColumn(11)のセルがMatchした場合は設定範囲の一つ目なので1が返ってきます。
このソースの場合、必ずColumn(11)から範囲開始となっているので10を加算することで正しいセルを取得できます。
もう一つはY.H.さんを同じ内容ですね。
AddShapeの5つ目の引数は書き出すシェイプのy軸幅を設定しますがこれがマイナスだと何も描き出されません。
現在はマイナスになっているので描き出されていないわけです。
回答では10を設定させてもらいました。
VBA
1Option Explicit 2 3Sub cmdSuchedule_Click() 4 5Dim ws1 As Worksheet 6Dim i As Long 7Dim st1 As Range, en1 As Range 8Dim dayEnd1 As Long, rowEnd1 As Long 9Dim rngStart1 As Range, rngEnd1 As Range 10Dim xStart1 As Single, yStart1 As Single, xEnd1 As Single, x1 As Single, y1 As Single 11 12 Set ws1 = ActiveSheet 13 14 With ws1 15 dayEnd1 = .Cells(6, Columns.Count).End(xlToLeft).Column 'カレンダー上の最終日付列の取得 16 rowEnd1 = .Cells(Rows.Count, 4).End(xlUp).Row 'タスクの最終行の取得 17 18 On Error Resume Next 19 For i = 8 To rowEnd1 20 21 If Cells(i, 5) <> "" And Cells(i, 6) <> "" Then 22 23 '開始予定日と終了予定日の対応列を設定する 24 Set st1 = .Cells(6, 10 + WorksheetFunction.Match(.Cells(i, 5), .Range(.Cells(6, 11), .Cells(6, dayEnd1)), 0)) '開始予定日のカレンダー上での対応列を設定 25 Set en1 = .Cells(6, 10 + WorksheetFunction.Match(.Cells(i, 6), .Range(.Cells(6, 11), .Cells(6, dayEnd1)), 0)) '終了予定日のカレンダー上での対応列を設定 26 27 '開始予定日と終了予定日の両方が見つかればバーを描画する 28 Set rngStart1 = .Cells(i, st1.Column) 'バーの描画開始セルの設定 29 Set rngEnd1 = .Cells(i, en1.Column + 1) 'バーの描画終了セルの1日後を設定 30 31 xStart1 = rngStart1.Left 'バーの描画開始位置のX座標 32 yStart1 = rngStart1.Top + 4 'バーの描画開始位置のY座標 33 xEnd1 = rngEnd1.Left 'バーの描画終了位置のX座標 34 'y1 = rngEnd1.Height - 70 'バーの高さ方向の幅 35 36 With .Shapes.AddShape(msoShapeRectangle, xStart1, yStart1, xEnd1 - xStart1, 10) 'オートシェイプでバーを追加 37 .Fill.ForeColor.RGB = RGB(255, 255, 255) 'バーの色を指定 38 .Line.ForeColor.RGB = RGB(0, 0, 0) '枠線の色を指定 39 End With 40 41 End If 42 43 Next i '次の行へ 44 End With 45 46End Sub 47
投稿2020/02/21 04:58
総合スコア2183
0
ベストアンサー
エラーメッセージは出ていませんが、
On Error Resume Nextしているのでエラーは出ませんね。
デバッグするときはOn Error Resume Nextを削除(コメントに)して実行してみましょう。
rngEnd1.Heightから70を引いてますが、この結果がマイナス値になって
Shapes.AddShape()がエラーになっているのでは？
行の高さが70って結構大きいですよ。
vba
1y1 = rngEnd1.Height - 70 'バーの高さ方向の幅
投稿2020/02/21 04:27
総合スコア7914
0
条件付き書式でもできますよ。
B4開始日 2020/2/10(シリアル値）
C4終了日 2020/2/20(シリアル値）
D2から右にカレンダーの日付け(シリアル値）
2020/2/1入力後右へオートフィル2020/3/1ほどまで
表示形式で日だけにしてもよいですね（セル幅狭めないと...）
D4セルに条件付き書式
ルールを
数式を指定して
=AND($B$4<=D$2,D$2<=$C$4)
でセル塗りつぶし
条件付き書式もカレンダーにあわせて右へコピー
投稿2020/02/21 05:34
総合スコア392
あなたの回答
tips
プレビュー
Q&A
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/02/21 06:58