質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.77%

ガントチャート VBA 描写について

解決済

回答 2

投稿

  • 評価
  • クリップ 1
  • VIEW 412

Mkasai

score 19

前提・実現したいこと

開始日と終了日が入力されている行のみ塗りつぶしを行いたい。
ボタンを押さなくても入力後エンターキーで実行できるようにする方法があるのかどうか。

発生している問題・エラーメッセージ

開始日と終了日を入力していない行も塗りつぶされるので、どの部分を修正したらいいのかわからない。
また、38行目にも開始日と終了日を入力しましたが、塗りつぶされないが、修正方法がわからない。

該当のソースコード

Sub ガントチャート描写()

'オートシェイプ一括消去
Call オートシェイプ一括消去

'予定日程バー追加
Call 予定日程バー追加

End Sub
Private Sub オートシェイプ一括消去()

Dim shp As Shape

For Each shp In ActiveSheet.Shapes

    If shp.Type = msoFormControl Then
        'マクロ実行ボタンである場合は何もしない
    Else
        shp.Delete  'マクロ実行ボタンでない図形は消去
    End If

Next shp

End Sub

Private Sub 予定日程バー追加()

Dim ws1 As Worksheet
Dim i As Long
Dim st As Range, en As Range
Dim dayEnd As Long, rowEnd As Long
Dim rngStart As Range, rngEnd As Range
Dim xStart As Single, yStart As Single, xEnd As Single, x As Single, y As Single

    Set ws1 = ActiveSheet

        With ws1
        dayEnd = .Cells(4, Columns.Count).End(xlToLeft).Column 'カレンダー上の最終日付列の取得
        rowEnd = .Cells(Rows.Count, 2).End(xlUp).Row 'タスク最終行の取得

            On Error Resume Next
            For i = 2 To rowEnd

                '開始日と終了日の対応列を設定する
                Set st = .Cells(4, WorksheetFunction.Match(.Cells(i, 4), .Range(.Cells(4, 1), .Cells(4, dayEnd)), 0)) '開始日のカレンダー上での対応列を設定
                Set en = .Cells(4, WorksheetFunction.Match(.Cells(i, 5), .Range(.Cells(4, 1), .Cells(4, dayEnd)), 0)) '終了日のカレンダー上での対応列を設定

                '開始日と終了日の両方が見つかればバーを描写する
                Set rngStart = .Cells(i, st.Column) 'バーの描写開始セルの設定
                Set rngEnd = .Cells(i, en.Column + 1) 'バーの描写終了セルの1日後を設定

                xStart = rngStart.Left  'バーの描写開始位置のX座標
                yStart = rngStart.Top 'バーの描写開始位置のY座標
                xEnd = rngEnd.Left 'バーの描写終了位置のX座標
                y = rngEnd.Height 'バーの高さの方向の幅

                With .Shapes.AddShape(msoShapeRectangle, xStart, yStart, xEnd - xStart, y) 'オートシェイプでバーを追加
                    .Fill.ForeColor.RGB = RGB(160, 229, 133) 'バーの色を指定
                    .Line.ForeColor.RGB = RGB(255, 255, 255) '枠線の色を指定
                End With

            Next i '次の行へ
        End With

End Sub

試したこと

上記のコードで実行しています。
インターネットで見たサンプルを参考にしました。
現在の実行後の画面です。

イメージ説明

補足情報(FW/ツールのバージョンなど)

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

+1

開始日と終了日が入力されている行のみ塗りつぶしを行いたい。

Forループの中の処理を開始日と終了日が入力されているときのみ処理するようにすればよいと思います。

For i = 2 To rowEnd
    If Not IsEmpty(.Cells(i, 4)) And Not IsEmpty(.Cells(i, 5) Then   ' 追加

~省略~

    End If   ' 追加
Next i '次の行へ

ボタンを押さなくても入力後エンターキーで実行できるようにする方法があるのかどうか。

ワークシートのChangeイベントで処理すればよいかと思います。
以下はD列E列を変更したときのみガントチャート描写関数を実行します。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("D:E")) Is Nothing Then
        Call ガントチャート描写
    End If
End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

checkベストアンサー

0

Sub main()
    With workshhets("試験予定")
        予定塗りつぶし .Range("G5", .Range("G5").End(xlToRight)), .Range("C11:D22")
    End With
End Sub

Sub 予定日塗りつぶし(ByRef rngDays As Range, ByRef rngDate As Range)
    Dim c As Range
    Dim rngTarget As Range
    Dim ixStart As Long
    Dim ixEnd As Long


    For Each c In rngDate.Rows
        ixStart = 0
        ixEnd = 0
        c.EntireRow.Interior.ColorIndex = xlNone

        On Error Resume Next
        With WorksheetFunction
            ixStart = .Match(c.Cells(1), rngDays, 0)
            ixEnd = .Match(c.Cells(2), rngDays, 0)
        End With
        On Error GoTo 0

        If ixStart > 0 And ixEnd > 0 Then
            Intersect(c.EntireRow, Application.Range(rngDays(ixStart), rngDays(ixEnd)).EntireColumn).Interior.Color = rgbPaleGreen
        End If
    Next
End Sub

子プロシージャには変わるものを与えて、
再利用できるよういするといいかもです。
図形書くのめんどいので塗りつぶしにしました。

>ボタンを押さなくても入力後エンターキーで実行できるようにする方法があるのかどうか。
条件付き書式設定で塗りつぶせば、
マクロは要らず、入力に対して反応してくれますよ。
(マクロ無効で開かれても動くし。。。。)
(最近便利かと思ってマクロ仕込んで置いたらマクロ無効で開かれて不評を買ってしまった。愚痴)

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/06/22 14:25

    図形より塗りつぶしが簡単ですね。
    教えていただいたコードで試してみました。
    アドバイスいただいたとおり、条件付きの書式設定で行ったほうが使いやすそうです。
    ありがとうございました。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.77%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る